Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'ocaml/trunk' into flambda_prereq-init_assign

master
Mark Shinwell 2016-01-12 15:33:54 +01:00
parent d65f99f72e f3cb90fcff
commit 029e1bbbbc
346 changed files with 29915 additions and 3637 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

427
.depend
View File

@ -1,27 +1,36 @@
utils/ccomp.cmi :
utils/clflags.cmi :
utils/clflags.cmi : utils/misc.cmi
utils/config.cmi :
utils/consistbl.cmi :
utils/misc.cmi : utils/clflags.cmi
utils/identifiable.cmi :
utils/misc.cmi :
utils/numbers.cmi : utils/identifiable.cmi
utils/tbl.cmi :
utils/terminfo.cmi :
utils/timings.cmi :
utils/warnings.cmi :
utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \
utils/ccomp.cmi
utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \
utils/ccomp.cmi
utils/clflags.cmo : utils/config.cmi utils/clflags.cmi
utils/clflags.cmx : utils/config.cmx utils/clflags.cmi
utils/clflags.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi
utils/clflags.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmi
utils/config.cmo : utils/config.cmi
utils/config.cmx : utils/config.cmi
utils/consistbl.cmo : utils/consistbl.cmi
utils/consistbl.cmx : utils/consistbl.cmi
utils/misc.cmo : utils/clflags.cmi utils/misc.cmi
utils/misc.cmx : utils/clflags.cmx utils/misc.cmi
utils/identifiable.cmo : utils/misc.cmi utils/identifiable.cmi
utils/identifiable.cmx : utils/misc.cmx utils/identifiable.cmi
utils/misc.cmo : utils/misc.cmi
utils/misc.cmx : utils/misc.cmi
utils/numbers.cmo : utils/identifiable.cmi utils/numbers.cmi
utils/numbers.cmx : utils/identifiable.cmx utils/numbers.cmi
utils/tbl.cmo : utils/tbl.cmi
utils/tbl.cmx : utils/tbl.cmi
utils/terminfo.cmo : utils/terminfo.cmi
utils/terminfo.cmx : utils/terminfo.cmi
utils/timings.cmo : utils/timings.cmi
utils/timings.cmx : utils/timings.cmi
utils/warnings.cmo : utils/warnings.cmi
utils/warnings.cmx : utils/warnings.cmi
parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \
@ -265,17 +274,17 @@ typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \
typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \
typing/oprint.cmi
typing/parmatch.cmo : utils/warnings.cmi typing/untypeast.cmi \
typing/types.cmi typing/typedtree.cmi typing/subst.cmi typing/predef.cmi \
typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \
parsing/ast_helper.cmi typing/parmatch.cmi
typing/types.cmi typing/typedtreeIter.cmi typing/typedtree.cmi \
typing/subst.cmi typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/btype.cmi \
parsing/asttypes.cmi parsing/ast_helper.cmi typing/parmatch.cmi
typing/parmatch.cmx : utils/warnings.cmx typing/untypeast.cmx \
typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/predef.cmx \
typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \
parsing/ast_helper.cmx typing/parmatch.cmi
typing/types.cmx typing/typedtreeIter.cmx typing/typedtree.cmx \
typing/subst.cmx typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \
utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/btype.cmx \
parsing/asttypes.cmi parsing/ast_helper.cmx typing/parmatch.cmi
typing/path.cmo : typing/ident.cmi typing/path.cmi
typing/path.cmx : typing/ident.cmx typing/path.cmi
typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
@ -446,6 +455,7 @@ bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi
bytecomp/bytepackager.cmi : typing/ident.cmi typing/env.cmi
bytecomp/bytesections.cmi :
bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi
bytecomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi
bytecomp/dll.cmi :
bytecomp/emitcode.cmi : bytecomp/instruct.cmi bytecomp/cmo_format.cmi
bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \
@ -514,6 +524,10 @@ bytecomp/bytepackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \
bytecomp/bytegen.cmx bytecomp/bytepackager.cmi
bytecomp/bytesections.cmo : utils/config.cmi bytecomp/bytesections.cmi
bytecomp/bytesections.cmx : utils/config.cmx bytecomp/bytesections.cmi
bytecomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \
bytecomp/debuginfo.cmi
bytecomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \
bytecomp/debuginfo.cmi
bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi
bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi
bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \
@ -622,16 +636,18 @@ bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \
typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi
bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \
bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
typing/ctype.cmi parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translattribute.cmi typing/printtyp.cmi typing/primitive.cmi \
typing/predef.cmi typing/path.cmi typing/mtype.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \
typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \
bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
typing/ctype.cmx parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translattribute.cmx typing/printtyp.cmx typing/primitive.cmx \
typing/predef.cmx typing/path.cmx typing/mtype.cmx utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translobj.cmo : typing/primitive.cmi utils/misc.cmi \
parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
@ -642,38 +658,44 @@ bytecomp/translobj.cmx : typing/primitive.cmx utils/misc.cmx \
bytecomp/translobj.cmi
bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \
typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi typing/ident.cmi \
typing/env.cmi typing/ctype.cmi bytecomp/typeopt.cmi
typing/env.cmi typing/ctype.cmi typing/btype.cmi bytecomp/typeopt.cmi
bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \
typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi
typing/env.cmx typing/ctype.cmx typing/btype.cmx bytecomp/typeopt.cmi
asmcomp/CSEgen.cmi : asmcomp/mach.cmi
asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi
asmcomp/asmgen.cmi : utils/timings.cmi bytecomp/lambda.cmi asmcomp/cmm.cmi
asmcomp/asmlibrarian.cmi :
asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi
asmcomp/asmpackager.cmi : typing/env.cmi
asmcomp/branch_relaxation.cmi : asmcomp/linearize.cmi \
asmcomp/branch_relaxation_intf.cmo
asmcomp/build_export_info.cmi : asmcomp/export_info.cmi
asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi parsing/asttypes.cmi
bytecomp/debuginfo.cmi parsing/asttypes.cmi
asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi
asmcomp/closure_offsets.cmi :
asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi \
bytecomp/debuginfo.cmi
asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
asmcomp/clambda.cmi
asmcomp/cmx_format.cmi : asmcomp/clambda.cmi
asmcomp/coloring.cmi :
asmcomp/comballoc.cmi : asmcomp/mach.cmi
asmcomp/compilenv.cmi : typing/ident.cmi asmcomp/cmx_format.cmi \
asmcomp/clambda.cmi
asmcomp/compilenv.cmi : utils/timings.cmi typing/ident.cmi \
asmcomp/cmx_format.cmi asmcomp/clambda.cmi
asmcomp/deadcode.cmi : asmcomp/mach.cmi
asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi
asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi
asmcomp/emitaux.cmi : bytecomp/debuginfo.cmi
asmcomp/export_info.cmi : typing/ident.cmi
asmcomp/export_info_for_pack.cmi : asmcomp/export_info.cmi
asmcomp/flambda_to_clambda.cmi : asmcomp/export_info.cmi asmcomp/clambda.cmi
asmcomp/import_approx.cmi :
asmcomp/interf.cmi : asmcomp/mach.cmi
asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \
asmcomp/debuginfo.cmi
bytecomp/debuginfo.cmi
asmcomp/liveness.cmi : asmcomp/mach.cmi
asmcomp/mach.cmi : asmcomp/reg.cmi bytecomp/lambda.cmi asmcomp/debuginfo.cmi \
asmcomp/cmm.cmi asmcomp/arch.cmo
asmcomp/mach.cmi : asmcomp/reg.cmi bytecomp/lambda.cmi \
bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
asmcomp/printclambda.cmi : asmcomp/clambda.cmi
asmcomp/printcmm.cmi : asmcomp/cmm.cmi
asmcomp/printlinear.cmi : asmcomp/linearize.cmi
@ -685,11 +707,12 @@ asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi
asmcomp/scheduling.cmi : asmcomp/linearize.cmi
asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
typing/ident.cmi bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi
asmcomp/spill.cmi : asmcomp/mach.cmi
asmcomp/split.cmi : asmcomp/mach.cmi
asmcomp/strmatch.cmi : asmcomp/cmm.cmi
asmcomp/un_anf.cmi : asmcomp/clambda.cmi
asmcomp/x86_ast.cmi :
asmcomp/x86_dsl.cmi : asmcomp/x86_ast.cmi
asmcomp/x86_gas.cmi : asmcomp/x86_ast.cmi
@ -703,26 +726,28 @@ asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
asmcomp/cmm.cmx asmcomp/CSEgen.cmi
asmcomp/arch.cmo : utils/clflags.cmi
asmcomp/arch.cmx : utils/clflags.cmx
asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \
asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \
asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \
typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \
asmcomp/liveness.cmi asmcomp/linearize.cmi asmcomp/interf.cmi \
asmcomp/emitaux.cmi asmcomp/emit.cmi asmcomp/deadcode.cmi \
utils/config.cmi asmcomp/compilenv.cmi asmcomp/comballoc.cmi \
asmcomp/coloring.cmi asmcomp/cmmgen.cmi asmcomp/cmm.cmi \
asmcomp/closure.cmi utils/clflags.cmi asmcomp/CSE.cmo asmcomp/asmgen.cmi
asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \
asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \
asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \
asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \
typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \
asmcomp/liveness.cmx asmcomp/linearize.cmx asmcomp/interf.cmx \
asmcomp/emitaux.cmx asmcomp/emit.cmx asmcomp/deadcode.cmx \
utils/config.cmx asmcomp/compilenv.cmx asmcomp/comballoc.cmx \
asmcomp/coloring.cmx asmcomp/cmmgen.cmx asmcomp/cmm.cmx \
asmcomp/closure.cmx utils/clflags.cmx asmcomp/CSE.cmx asmcomp/asmgen.cmi
asmcomp/asmgen.cmo : bytecomp/translmod.cmi utils/timings.cmi \
asmcomp/split.cmi asmcomp/spill.cmi asmcomp/selection.cmi \
asmcomp/scheduling.cmi asmcomp/reload.cmi asmcomp/reg.cmi \
asmcomp/proc.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \
asmcomp/printcmm.cmi asmcomp/printclambda.cmi typing/primitive.cmi \
utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi asmcomp/liveness.cmi \
asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \
asmcomp/emit.cmi asmcomp/deadcode.cmi utils/config.cmi \
asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \
asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \
asmcomp/CSE.cmo asmcomp/asmgen.cmi
asmcomp/asmgen.cmx : bytecomp/translmod.cmx utils/timings.cmx \
asmcomp/split.cmx asmcomp/spill.cmx asmcomp/selection.cmx \
asmcomp/scheduling.cmx asmcomp/reload.cmx asmcomp/reg.cmx \
asmcomp/proc.cmx asmcomp/printmach.cmx asmcomp/printlinear.cmx \
asmcomp/printcmm.cmx asmcomp/printclambda.cmx typing/primitive.cmx \
utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx asmcomp/liveness.cmx \
asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \
asmcomp/emit.cmx asmcomp/deadcode.cmx utils/config.cmx \
asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \
asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \
asmcomp/CSE.cmx asmcomp/asmgen.cmi
asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \
utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \
utils/clflags.cmi asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \
@ -731,26 +756,26 @@ asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \
utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \
utils/clflags.cmx asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \
asmcomp/asmlibrarian.cmi
asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi utils/misc.cmi \
parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \
asmcomp/asmlink.cmo : utils/timings.cmi bytecomp/runtimedef.cmi \
utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \
utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \
asmcomp/cmx_format.cmi asmcomp/cmmgen.cmi utils/clflags.cmi \
utils/ccomp.cmi asmcomp/asmgen.cmi asmcomp/asmlink.cmi
asmcomp/asmlink.cmx : bytecomp/runtimedef.cmx utils/misc.cmx \
parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \
asmcomp/asmlink.cmx : utils/timings.cmx bytecomp/runtimedef.cmx \
utils/misc.cmx parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \
utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \
utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi
asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \
utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \
utils/clflags.cmi utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
asmcomp/asmpackager.cmi
utils/timings.cmi utils/misc.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi \
asmcomp/cmx_format.cmi utils/clflags.cmi utils/ccomp.cmi \
asmcomp/asmlink.cmi asmcomp/asmgen.cmi asmcomp/asmpackager.cmi
asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \
utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \
utils/clflags.cmx utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \
asmcomp/asmpackager.cmi
utils/timings.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \
typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmx_format.cmi utils/clflags.cmx utils/ccomp.cmx \
asmcomp/asmlink.cmx asmcomp/asmgen.cmx asmcomp/asmpackager.cmi
asmcomp/branch_relaxation.cmo : utils/misc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/branch_relaxation_intf.cmo \
asmcomp/branch_relaxation.cmi
@ -759,33 +784,43 @@ asmcomp/branch_relaxation.cmx : utils/misc.cmx asmcomp/mach.cmx \
asmcomp/branch_relaxation.cmi
asmcomp/branch_relaxation_intf.cmo : asmcomp/linearize.cmi asmcomp/arch.cmo
asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/arch.cmx
asmcomp/build_export_info.cmo : utils/misc.cmi typing/ident.cmi \
asmcomp/export_info.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
asmcomp/build_export_info.cmi
asmcomp/build_export_info.cmx : utils/misc.cmx typing/ident.cmx \
asmcomp/export_info.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
asmcomp/build_export_info.cmi
asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
bytecomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \
asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
bytecomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/closure.cmo : utils/warnings.cmi utils/tbl.cmi bytecomp/switch.cmi \
typing/primitive.cmi utils/misc.cmi parsing/location.cmi \
bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \
parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/closure.cmi
bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
bytecomp/debuginfo.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
asmcomp/closure.cmi
asmcomp/closure.cmx : utils/warnings.cmx utils/tbl.cmx bytecomp/switch.cmx \
typing/primitive.cmx utils/misc.cmx parsing/location.cmx \
bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \
parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi
asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
asmcomp/arch.cmo asmcomp/cmm.cmi
asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
asmcomp/arch.cmx asmcomp/cmm.cmi
bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
bytecomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
asmcomp/closure.cmi
asmcomp/closure_offsets.cmo : utils/misc.cmi asmcomp/closure_offsets.cmi
asmcomp/closure_offsets.cmx : utils/misc.cmx asmcomp/closure_offsets.cmi
asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \
bytecomp/debuginfo.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \
bytecomp/debuginfo.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi \
asmcomp/strmatch.cmi asmcomp/proc.cmi typing/primitive.cmi utils/misc.cmi \
bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
bytecomp/lambda.cmi typing/ident.cmi bytecomp/debuginfo.cmi \
utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \
asmcomp/cmm.cmi utils/clflags.cmi asmcomp/clambda.cmi \
parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/cmmgen.cmi
asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx \
asmcomp/strmatch.cmx asmcomp/proc.cmx typing/primitive.cmx utils/misc.cmx \
bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
bytecomp/lambda.cmx typing/ident.cmx bytecomp/debuginfo.cmx \
utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/clambda.cmx \
parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/cmmgen.cmi
@ -795,47 +830,61 @@ asmcomp/comballoc.cmo : asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \
asmcomp/arch.cmo asmcomp/comballoc.cmi
asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \
asmcomp/arch.cmx asmcomp/comballoc.cmi
asmcomp/compilenv.cmo : utils/misc.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi utils/config.cmi asmcomp/cmx_format.cmi \
asmcomp/clambda.cmi asmcomp/compilenv.cmi
asmcomp/compilenv.cmx : utils/misc.cmx parsing/location.cmx typing/ident.cmx \
typing/env.cmx utils/config.cmx asmcomp/cmx_format.cmi \
asmcomp/clambda.cmx asmcomp/compilenv.cmi
asmcomp/compilenv.cmo : utils/warnings.cmi utils/misc.cmi \
parsing/location.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
asmcomp/cmx_format.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi
asmcomp/compilenv.cmx : utils/warnings.cmx utils/misc.cmx \
parsing/location.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
asmcomp/cmx_format.cmi asmcomp/clambda.cmx asmcomp/compilenv.cmi
asmcomp/deadcode.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/deadcode.cmi
asmcomp/deadcode.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
asmcomp/deadcode.cmi
asmcomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \
asmcomp/debuginfo.cmi
asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \
asmcomp/debuginfo.cmi
asmcomp/emit.cmo : asmcomp/x86_proc.cmi asmcomp/x86_masm.cmi \
asmcomp/x86_gas.cmi asmcomp/x86_dsl.cmi asmcomp/x86_ast.cmi \
asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/emitaux.cmi \
asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
bytecomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
asmcomp/cmm.cmi utils/clflags.cmi asmcomp/branch_relaxation.cmi \
asmcomp/arch.cmo asmcomp/emit.cmi
asmcomp/emit.cmx : asmcomp/x86_proc.cmx asmcomp/x86_masm.cmx \
asmcomp/x86_gas.cmx asmcomp/x86_dsl.cmx asmcomp/x86_ast.cmi \
asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/emitaux.cmx \
asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
bytecomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/branch_relaxation.cmx \
asmcomp/arch.cmx asmcomp/emit.cmi
asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \
asmcomp/emitaux.cmo : asmcomp/linearize.cmi bytecomp/debuginfo.cmi \
utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \
asmcomp/emitaux.cmx : asmcomp/linearize.cmx bytecomp/debuginfo.cmx \
utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/export_info.cmo : typing/ident.cmi asmcomp/export_info.cmi
asmcomp/export_info.cmx : typing/ident.cmx asmcomp/export_info.cmi
asmcomp/export_info_for_pack.cmo : utils/misc.cmi typing/ident.cmi \
asmcomp/export_info.cmi asmcomp/export_info_for_pack.cmi
asmcomp/export_info_for_pack.cmx : utils/misc.cmx typing/ident.cmx \
asmcomp/export_info.cmx asmcomp/export_info_for_pack.cmi
asmcomp/flambda_to_clambda.cmo : typing/primitive.cmi utils/numbers.cmi \
utils/misc.cmi typing/ident.cmi asmcomp/export_info.cmi \
bytecomp/debuginfo.cmi asmcomp/compilenv.cmi asmcomp/closure_offsets.cmi \
utils/clflags.cmi asmcomp/clambda.cmi asmcomp/flambda_to_clambda.cmi
asmcomp/flambda_to_clambda.cmx : typing/primitive.cmx utils/numbers.cmx \
utils/misc.cmx typing/ident.cmx asmcomp/export_info.cmx \
bytecomp/debuginfo.cmx asmcomp/compilenv.cmx asmcomp/closure_offsets.cmx \
utils/clflags.cmx asmcomp/clambda.cmx asmcomp/flambda_to_clambda.cmi
asmcomp/import_approx.cmo : utils/misc.cmi asmcomp/export_info.cmi \
asmcomp/compilenv.cmi asmcomp/import_approx.cmi
asmcomp/import_approx.cmx : utils/misc.cmx asmcomp/export_info.cmx \
asmcomp/compilenv.cmx asmcomp/import_approx.cmi
asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/interf.cmi
asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
asmcomp/interf.cmi
asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi bytecomp/lambda.cmi asmcomp/debuginfo.cmi \
asmcomp/mach.cmi bytecomp/lambda.cmi bytecomp/debuginfo.cmi \
asmcomp/cmm.cmi asmcomp/linearize.cmi
asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
asmcomp/mach.cmx bytecomp/lambda.cmx asmcomp/debuginfo.cmx \
asmcomp/mach.cmx bytecomp/lambda.cmx bytecomp/debuginfo.cmx \
asmcomp/cmm.cmx asmcomp/linearize.cmi
asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi \
@ -843,10 +892,10 @@ asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/liveness.cmi
asmcomp/mach.cmo : asmcomp/reg.cmi bytecomp/lambda.cmi asmcomp/debuginfo.cmi \
asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/mach.cmi
asmcomp/mach.cmx : asmcomp/reg.cmx bytecomp/lambda.cmx asmcomp/debuginfo.cmx \
asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/mach.cmi
asmcomp/mach.cmo : asmcomp/reg.cmi bytecomp/lambda.cmi \
bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/mach.cmi
asmcomp/mach.cmx : asmcomp/reg.cmx bytecomp/lambda.cmx \
bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/mach.cmi
asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \
typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \
asmcomp/printclambda.cmi
@ -854,22 +903,22 @@ asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \
typing/ident.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \
asmcomp/printclambda.cmi
asmcomp/printcmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi
bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi
asmcomp/printcmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \
asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi
bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi
asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/debuginfo.cmi \
asmcomp/linearize.cmi bytecomp/lambda.cmi bytecomp/debuginfo.cmi \
asmcomp/printlinear.cmi
asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/mach.cmx \
asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/debuginfo.cmx \
asmcomp/linearize.cmx bytecomp/lambda.cmx bytecomp/debuginfo.cmx \
asmcomp/printlinear.cmi
asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
asmcomp/printcmm.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \
asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/printmach.cmi
asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
asmcomp/printcmm.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \
asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
asmcomp/printmach.cmi
asmcomp/proc.cmo : asmcomp/x86_proc.cmi asmcomp/reg.cmi utils/misc.cmi \
asmcomp/mach.cmi utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
@ -897,11 +946,11 @@ asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi
asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.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 asmcomp/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.cmi \
typing/ident.cmi bytecomp/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.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 asmcomp/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \
typing/ident.cmx bytecomp/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \
asmcomp/arch.cmx asmcomp/selectgen.cmi
asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \
asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \
@ -921,6 +970,14 @@ asmcomp/strmatch.cmo : bytecomp/lambda.cmi typing/ident.cmi asmcomp/cmm.cmi \
asmcomp/arch.cmo asmcomp/strmatch.cmi
asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/cmm.cmx \
asmcomp/arch.cmx asmcomp/strmatch.cmi
asmcomp/un_anf.cmo : asmcomp/printclambda.cmi utils/misc.cmi \
bytecomp/lambda.cmi typing/ident.cmi bytecomp/debuginfo.cmi \
utils/config.cmi utils/clflags.cmi asmcomp/clambda.cmi \
parsing/asttypes.cmi asmcomp/un_anf.cmi
asmcomp/un_anf.cmx : asmcomp/printclambda.cmx utils/misc.cmx \
bytecomp/lambda.cmx typing/ident.cmx bytecomp/debuginfo.cmx \
utils/config.cmx utils/clflags.cmx asmcomp/clambda.cmx \
parsing/asttypes.cmi asmcomp/un_anf.cmi
asmcomp/x86_dsl.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \
asmcomp/x86_dsl.cmi
asmcomp/x86_dsl.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \
@ -953,22 +1010,22 @@ driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \
utils/config.cmx utils/clflags.cmx driver/compenv.cmi
driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \
typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \
parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \
utils/misc.cmi parsing/location.cmi typing/includemod.cmi typing/env.cmi \
bytecomp/emitcode.cmi driver/compmisc.cmi driver/compenv.cmi \
utils/clflags.cmi utils/ccomp.cmi bytecomp/bytegen.cmi \
parsing/builtin_attributes.cmi driver/compile.cmi
utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \
typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
bytecomp/printinstr.cmi parsing/printast.cmi parsing/pprintast.cmi \
driver/pparse.cmi utils/misc.cmi parsing/location.cmi \
typing/includemod.cmi typing/env.cmi bytecomp/emitcode.cmi \
driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi utils/ccomp.cmi \
bytecomp/bytegen.cmi parsing/builtin_attributes.cmi driver/compile.cmi
driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \
typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \
parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \
utils/misc.cmx parsing/location.cmx typing/includemod.cmx typing/env.cmx \
bytecomp/emitcode.cmx driver/compmisc.cmx driver/compenv.cmx \
utils/clflags.cmx utils/ccomp.cmx bytecomp/bytegen.cmx \
parsing/builtin_attributes.cmx driver/compile.cmi
utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
bytecomp/printinstr.cmx parsing/printast.cmx parsing/pprintast.cmx \
driver/pparse.cmx utils/misc.cmx parsing/location.cmx \
typing/includemod.cmx typing/env.cmx bytecomp/emitcode.cmx \
driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx utils/ccomp.cmx \
bytecomp/bytegen.cmx parsing/builtin_attributes.cmx driver/compile.cmi
driver/compmisc.cmo : typing/typemod.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi utils/config.cmi driver/compenv.cmi utils/clflags.cmi \
@ -979,56 +1036,56 @@ driver/compmisc.cmx : typing/typemod.cmx utils/misc.cmx \
parsing/asttypes.cmi driver/compmisc.cmi
driver/errors.cmo : parsing/location.cmi driver/errors.cmi
driver/errors.cmx : parsing/location.cmx driver/errors.cmi
driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
parsing/location.cmi utils/config.cmi driver/compmisc.cmi \
driver/compile.cmi driver/compenv.cmi utils/clflags.cmi \
bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
driver/main.cmo : utils/warnings.cmi utils/timings.cmi utils/misc.cmi \
driver/main_args.cmi parsing/location.cmi utils/config.cmi \
driver/compmisc.cmi driver/compile.cmi driver/compenv.cmi \
utils/clflags.cmi bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
bytecomp/bytelibrarian.cmi driver/main.cmi
driver/main.cmx : utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \
parsing/location.cmx utils/config.cmx driver/compmisc.cmx \
driver/compile.cmx driver/compenv.cmx utils/clflags.cmx \
bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
driver/main.cmx : utils/warnings.cmx utils/timings.cmx utils/misc.cmx \
driver/main_args.cmx parsing/location.cmx utils/config.cmx \
driver/compmisc.cmx driver/compile.cmx driver/compenv.cmx \
utils/clflags.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx driver/main.cmi
driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \
typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \
parsing/pprintast.cmi driver/pparse.cmi utils/misc.cmi \
typing/includemod.cmi typing/env.cmi utils/config.cmi driver/compmisc.cmi \
asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \
utils/ccomp.cmi parsing/builtin_attributes.cmi asmcomp/asmgen.cmi \
driver/optcompile.cmi
utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \
typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \
utils/misc.cmi typing/includemod.cmi typing/env.cmi utils/config.cmi \
driver/compmisc.cmi asmcomp/compilenv.cmi driver/compenv.cmi \
utils/clflags.cmi utils/ccomp.cmi parsing/builtin_attributes.cmi \
asmcomp/asmgen.cmi driver/optcompile.cmi
driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \
typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \
typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \
parsing/pprintast.cmx driver/pparse.cmx utils/misc.cmx \
typing/includemod.cmx typing/env.cmx utils/config.cmx driver/compmisc.cmx \
asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \
utils/ccomp.cmx parsing/builtin_attributes.cmx asmcomp/asmgen.cmx \
driver/optcompile.cmi
utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \
utils/misc.cmx typing/includemod.cmx typing/env.cmx utils/config.cmx \
driver/compmisc.cmx asmcomp/compilenv.cmx driver/compenv.cmx \
utils/clflags.cmx utils/ccomp.cmx parsing/builtin_attributes.cmx \
asmcomp/asmgen.cmx driver/optcompile.cmi
driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi
driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi
driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
driver/optcompile.cmi utils/misc.cmi driver/main_args.cmi \
parsing/location.cmi utils/config.cmi driver/compmisc.cmi \
driver/compenv.cmi utils/clflags.cmi asmcomp/asmpackager.cmi \
asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi asmcomp/arch.cmo \
driver/optmain.cmi
driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \
driver/optcompile.cmx utils/misc.cmx driver/main_args.cmx \
parsing/location.cmx utils/config.cmx driver/compmisc.cmx \
driver/compenv.cmx utils/clflags.cmx asmcomp/asmpackager.cmx \
asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \
driver/optmain.cmi
driver/pparse.cmo : parsing/parse.cmi utils/misc.cmi parsing/location.cmi \
utils/config.cmi utils/clflags.cmi utils/ccomp.cmi parsing/ast_mapper.cmi \
driver/pparse.cmi
driver/pparse.cmx : parsing/parse.cmx utils/misc.cmx parsing/location.cmx \
utils/config.cmx utils/clflags.cmx utils/ccomp.cmx parsing/ast_mapper.cmx \
driver/pparse.cmi
driver/optmain.cmo : utils/warnings.cmi utils/timings.cmi \
asmcomp/printmach.cmi driver/optcompile.cmi utils/misc.cmi \
driver/main_args.cmi parsing/location.cmi utils/config.cmi \
driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \
asmcomp/arch.cmo driver/optmain.cmi
driver/optmain.cmx : utils/warnings.cmx utils/timings.cmx \
asmcomp/printmach.cmx driver/optcompile.cmx utils/misc.cmx \
driver/main_args.cmx parsing/location.cmx utils/config.cmx \
driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \
asmcomp/arch.cmx driver/optmain.cmi
driver/pparse.cmo : utils/timings.cmi parsing/parse.cmi utils/misc.cmi \
parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
parsing/ast_mapper.cmi driver/pparse.cmi
driver/pparse.cmx : utils/timings.cmx parsing/parse.cmx utils/misc.cmx \
parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \
parsing/ast_mapper.cmx driver/pparse.cmi
toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \
typing/outcometree.cmi typing/env.cmi
toplevel/opttopdirs.cmi : parsing/longident.cmi
@ -1069,28 +1126,28 @@ toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \
toplevel/opttopdirs.cmi
toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \
typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \
bytecomp/translmod.cmi bytecomp/simplif.cmi typing/printtyped.cmi \
typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \
typing/predef.cmi parsing/pprintast.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \
typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi parsing/lexer.cmi typing/ident.cmi \
toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \
driver/compmisc.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
typing/btype.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
toplevel/opttoploop.cmi
bytecomp/translmod.cmi utils/timings.cmi bytecomp/simplif.cmi \
typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
parsing/printast.cmi typing/predef.cmi parsing/pprintast.cmi \
driver/pparse.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \
typing/includemod.cmi typing/ident.cmi toplevel/genprintval.cmi \
typing/env.cmi utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \
utils/clflags.cmi typing/btype.cmi parsing/ast_helper.cmi \
asmcomp/asmlink.cmi asmcomp/asmgen.cmi toplevel/opttoploop.cmi
toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \
typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
bytecomp/translmod.cmx bytecomp/simplif.cmx typing/printtyped.cmx \
typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \
typing/predef.cmx parsing/pprintast.cmx typing/path.cmx \
parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \
typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx parsing/lexer.cmx typing/ident.cmx \
toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \
driver/compmisc.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
typing/btype.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \
toplevel/opttoploop.cmi
bytecomp/translmod.cmx utils/timings.cmx bytecomp/simplif.cmx \
typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
parsing/printast.cmx typing/predef.cmx parsing/pprintast.cmx \
driver/pparse.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \
typing/includemod.cmx typing/ident.cmx toplevel/genprintval.cmx \
typing/env.cmx utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \
utils/clflags.cmx typing/btype.cmx parsing/ast_helper.cmx \
asmcomp/asmlink.cmx asmcomp/asmgen.cmx toplevel/opttoploop.cmi
toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \
driver/main_args.cmi parsing/location.cmi utils/config.cmi \

10
.gitignore vendored
View File

@ -127,6 +127,9 @@
/lex/ocamllex.opt
/lex/parser.output
/manual/manual/cmds/warnings-help.etex
/manual/manual/warnings-help.etex
/ocamlbuild/ocamlbuild_config.ml
/ocamlbuild/lexers.ml
/ocamlbuild/glob_lexer.ml
@ -197,8 +200,8 @@
/stdlib/camlheader
/stdlib/target_camlheader
/stdlib/camlheaderd
/stdlib/target_camlheaderd
/stdlib/camlheader[di]
/stdlib/target_camlheader[di]
/stdlib/camlheader_ur
/stdlib/labelled-*
/stdlib/caml
@ -254,6 +257,7 @@
/testsuite/tests/unboxed-primitive-args/stubs.c
/testsuite/tests/warnings/w55.opt.opt_result
/testsuite/tests/warnings/w58.opt.opt_result
/tools/ocamldep
/tools/ocamldep.opt
@ -282,6 +286,8 @@
/tools/objinfo_helper
/tools/read_cmt
/tools/read_cmt.opt
/tools/cmpbyt
/tools/stripdebug
/utils/config.ml

38
Changes
View File

@ -63,6 +63,7 @@ Compilers:
- PR#4080, PR#6537, PR#5333: fix stack overflow in the compiler when -pack'ing
a module
that includes a module of the same name (Alain Frisch)
- PR#4231, PR#5461: (interim solution) warning 31 is now fatal by default
- PR#4800: better compilation of tuple assignment (Gabriel Scherer and
Alain Frisch)
- PR#5995: keep -for-pack into account to name exceptions; document -for-pack
@ -100,6 +101,8 @@ Compilers:
- PR#7067: Performance regression in the native compiler for long
nested structures (Alain Frisch, report by Daniel Bünzli, review
by Jacques Garrigue)
- PR#7097: Strange syntax error message around illegal packaged module signature
constraints (Alain Frisch, report by Jun Furuse)
- GPR#17: some cmm optimizations of integer operations with constants
(Stephen Dolan, review by Pierre Chambart)
- GPR#109: new unboxing strategy for float and int references (Vladimir Brankov,
@ -128,6 +131,11 @@ Compilers:
- GPR#282: relax short-paths safety check in presence of module aliases, take
penalty into account while building the printing map.
(Thomas Refis, Leo White)
- GPR#306: Instrument the compiler to debug performance regressions
(Pierre Chambart)
- GPR#319: add warning for missing cmx files, and extend -opaque option to mli
files.
(Leo White)
- PR#6920: fix debug informations around uses of %apply or %revapply
(Jérémie Dimino)
@ -152,6 +160,8 @@ Runtime system:
Shinwell, review by Damien Doligez)
- GPR#325: Add v=0x400 flag to OCAMLRUNPARAM to display GC stats on exit (Louis
Gesbert, review by Alain Frisch)
- GPR#297: Several changes to improve the worst-case GC pause time.
(Damien Doligez, with help from Leo White and Francois Bobot)
Standard library:
- PR#5197, GPR#63: Arg: allow flags such as --flag=arg as well as --flag arg
@ -167,11 +177,14 @@ Standard library:
(for conformance with ISO C99) (Xavier Leroy)
- PR#6390, GPR#36: expose Sys.{int_size,max_wosize} for improved js_of_ocaml
portability (Hugo Heuzard)
- PR#6449: Add Map.union (Alain Frisch)
* PR#6494: Add equal function in modules
Bytes, Char, Digest, Int32, Int64, Nativeint, and String
(Romain Calascibetta)
* PR#6524, GPR#79: Filename: Optional ?perms argument to open_temp_file
(Daniel Bünzli, review by Jacques-Pascal Deplaix)
* PR#6525, GPR#80: Add Uchar module to the standard library
(Daniel Bünzli, review by Yoriyuki Yamagata and Damien Doligez)
- PR#6577: improve performance of %L, %l, %n, %S, %C format specifiers
(Alain Frisch)
- PR#6585: fix memory leak in win32unix/createprocess.c
@ -217,6 +230,7 @@ Standard library:
(Bobot François)
- GPR#329: Add exists, for_all, mem and memq functions in Array
(Bernhard Schommer)
- GPR#356: Add [Format.kasprintf] (Jérémie Dimino, Mark Shinwell)
Type system:
- PR#5545: Type annotations on methods cannot control the choice of abbreviation
@ -227,6 +241,8 @@ Type system:
- PR#6593: Functor application in tests/basic-modules fails after commit 15405
Toplevel and debugger:
- PR#6113: Add descriptions to directives, and display them via #help
(Nick Giannarakis, Berke Durak, Francis Southern and Gabriel Scherer)
- PR#6396: Warnings-as-errors not properly flushed in the toplevel
(Alain Frisch)
- PR#6468: toplevel now supports backtraces if invoked with OCAMLRUNPARAM=b
@ -240,8 +256,10 @@ Toplevel and debugger:
(Valentin Gatien-Baron, review by Jérémie Dimino)
- PR#7098: Loss of ppx context in toplevel after an exception
(Alain Frisch, report by whitequark)
- PR#7101: The toplevel does not close in_channel for libraries specified on its command line
(Alain Frisch)
- PR#7101: The toplevel does not close in_channel for libraries specified on
its command line (Alain Frisch)
- PR#7119: ocaml doesn't respect [@@@warning] (Alain Frisch, report by
Gabriel Radanne)
Other libraries:
* Unix library: channels created by Unix.in_channel_of_descr or
@ -289,6 +307,12 @@ Manual:
subdirectory of the main OCaml source repository. Contributions to
the manual are warmly welcome.
(François Bobot, review by Florian Angeletti)
- MPR#6676: ongoing simplification of the "Language Extensions" section
(Alain Frisch, John Whitington)
- MPR#7092, GPR#379: Add missing documentation for new 4.03 features
(Florian Angeletti)
- MPR#7109, GPR#380: Fix bigarray documentation layout
(Florian Angeletti, Leo White)
Bug fixes:
- PR#3612: memory leak in bigarray read from file
@ -395,7 +419,11 @@ Bug fixes:
- PR#7075: Fix repetitions in ocamldoc generated documentation
(Florian Angeletti)
- PR#7082: Object type in recursive module's `with` annotation
- PR#7108: ocamldoc, have -html preserve custom/extended html generators
(Armaël Guéneau)
- PR#7096: ocamldoc uses an incorrect subscript/superscript style
- PR#7115: shadowing in a branch of a GADT match breaks unused variable
warning (Alain Frisch, report by Valentin Gatien-Baron)
- GPR#205: Clear caml_backtrace_last_exn before registering as root
(report and fix by Frederic Bour)
- GPR#220: minor -dsource error on recursive modules
@ -419,6 +447,8 @@ Bug fixes:
(Jérémie Dimino)
- GPR#355: make ocamlnat build again
(Jérémie Dimino, Thomas Refis)
- GPR#405: fix compilation under Visual Studio 2015
(David Allsopp)
Features wishes:
- PR#4518, GPR#29: change location format for reporting errors in ocamldoc
@ -485,6 +515,10 @@ Features wishes:
(Hugo Heuzard)
- GPR#308: add experimental support for NetBSD/arm (verified on RaspberryPi)
(Rich Neswold)
- GPR#365: prevent printing just a single type variable on one side
of a type error clash. (Hugo Heuzard)
- GPR#383: configure: define _ALL_SOURCE for build on AIX7.1
(tkob)
OCaml 4.02.3 (27 Jul 2015):
---------------------------

4
INSTALL.adoc
View File

@ -106,6 +106,10 @@ The `configure` script accepts the following options:
Compile and install the debug version of the runtimes, useful
for debugging C stubs and other low-level code.
-with-instrumented-runtime::
Compile and install the instrumented version of the runtimes,
useful mainly for fine-tuning the GC. Works only on Linux.
-verbose::
Verbose output of the configuration tests. Use it if the outcome
of configure is not what you were expecting.

2
Makefile
View File

@ -267,6 +267,8 @@ 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 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 \

4
Makefile.nt
View File

@ -127,7 +127,7 @@ opt:
# Native-code versions of the tools
opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \
ocamltoolsopt ocamltoolsopt.opt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT)
ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT)
# Complete build using fast compilers
world.opt: coldstart opt.opt
@ -203,6 +203,8 @@ 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 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) \

7
Makefile.shared
View File

@ -37,7 +37,9 @@ INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
-I toplevel
UTILS=utils/config.cmo utils/clflags.cmo \
utils/misc.cmo utils/tbl.cmo \
utils/misc.cmo \
utils/identifiable.cmo utils/numbers.cmo \
utils/tbl.cmo utils/timings.cmo \
utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
utils/consistbl.cmo
@ -71,6 +73,7 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
bytecomp/translcore.cmo \
bytecomp/translclass.cmo bytecomp/translmod.cmo \
bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
bytecomp/debuginfo.cmo \
driver/pparse.cmo driver/main_args.cmo \
driver/compenv.cmo driver/compmisc.cmo
@ -98,7 +101,7 @@ endif
ASMCOMP=\
$(ARCH_SPECIFIC_ASMCOMP) \
asmcomp/arch.cmo asmcomp/debuginfo.cmo \
asmcomp/arch.cmo \
asmcomp/cmm.cmo asmcomp/printcmm.cmo \
asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \

2
VERSION
View File

@ -1,4 +1,4 @@
4.03.0+dev11-2015-10-19
4.03.0+dev12-2015-11-20
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli

22
asmcomp/amd64/NOTES.md Normal file
View File

@ -0,0 +1,22 @@
# Supported platforms
Intel and AMD x86 processors in 64-bit mode, a.k.a `x86_64`.
Floating-point architecture: SSE2, supported by all x86_64 processors.
Operating systems: Linux, BSD, MacOS X, MS Windows.
Debian architecture name: `amd64`
# Reference documents
* Instruction set architecture:
any Intel or AMD manual less than 10 years old.
* ELF application binary interface:
_System V Application Binary Interface,
AMD64 Architecture Processor Supplement_
* MacOS X application binary interface:
_OS X ABI Function Call Guide: x86-64 Function Calling Conventions_
* Windows 64 application binary interface:
_x64 Software Conventions_ from MSDN

21
asmcomp/arm/NOTES.md Normal file
View File

@ -0,0 +1,21 @@
# Supported platforms
A great many variants of the ARM 32-bit architecture:
* Architecture versions: v4, v5, v5te, v6, v6t2, v7.
ARMv7 is the standard nowadays.
* Instruction encoding: classic ARM or Thumb or Thumb-2.
* Floating-point: software emulation, VFPv2, VFPv3-d16, VFP-v3.
* ABI: the standard EABI (with floats passed in integer registers)
or the EABI-HF variant (with floats passed in VFP registers).
Debian architecture names: `armel` and `armhf`.
# Reference documents
* Instruction set architecture:
_ARM Architecture Reference Manual, ARMv7-A and ARMv7-R edition_.
Alternatively:
_ARM Architecture Reference Manual, ARMv8_, restricted to the AArch32 subset.
* Application binary interface:
_Procedure Call Standard for the ARM Architecture_

12
asmcomp/arm64/NOTES.md Normal file
View File

@ -0,0 +1,12 @@
# Supported platforms
ARMv8 in 64-bit mode (AArch64).
Debian architecture name: `arm64`.
# Reference documents
* Instruction set architecture:
_ARM Architecture Reference Manual, ARMv8_, restricted to the AArch64 subset.
* Application binary interface:
_Procedure Call Standard for the ARM 64-bit Architecture (AArch64)_

51
asmcomp/asmgen.ml
View File

@ -59,28 +59,29 @@ let (++) x f = f x
let compile_fundecl (ppf : formatter) fd_cmm =
Proc.init ();
Reg.reset();
let build = Compilenv.current_build () in
fd_cmm
++ Selection.fundecl
++ Timings.(accumulate_time (Selection build)) Selection.fundecl
++ pass_dump_if ppf dump_selection "After instruction selection"
++ Comballoc.fundecl
++ Timings.(accumulate_time (Comballoc build)) Comballoc.fundecl
++ pass_dump_if ppf dump_combine "After allocation combining"
++ CSE.fundecl
++ Timings.(accumulate_time (CSE build)) CSE.fundecl
++ pass_dump_if ppf dump_cse "After CSE"
++ liveness ppf
++ Deadcode.fundecl
++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
++ Timings.(accumulate_time (Deadcode build)) Deadcode.fundecl
++ pass_dump_if ppf dump_live "Liveness analysis"
++ Spill.fundecl
++ liveness ppf
++ Timings.(accumulate_time (Spill build)) Spill.fundecl
++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
++ pass_dump_if ppf dump_spill "After spilling"
++ Split.fundecl
++ Timings.(accumulate_time (Split build)) Split.fundecl
++ pass_dump_if ppf dump_split "After live range splitting"
++ liveness ppf
++ regalloc ppf 1
++ Linearize.fundecl
++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
++ Timings.(accumulate_time (Regalloc build)) (regalloc ppf 1)
++ Timings.(accumulate_time (Linearize build)) Linearize.fundecl
++ pass_dump_linear_if ppf dump_linear "Linearized code"
++ Scheduling.fundecl
++ Timings.(accumulate_time (Scheduling build)) Scheduling.fundecl
++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling"
++ Emit.fundecl
++ Timings.(accumulate_time (Emit build)) Emit.fundecl
let compile_phrase ppf p =
if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p;
@ -99,7 +100,7 @@ let compile_genfuns ppf f =
| _ -> ())
(Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
let compile_unit asm_filename keep_asm obj_filename gen =
let compile_unit ~source_provenance asm_filename keep_asm obj_filename gen =
let create_asm = keep_asm || not !Emitaux.binary_backend_available in
Emitaux.create_asm_file := create_asm;
try
@ -112,19 +113,25 @@ let compile_unit asm_filename keep_asm obj_filename gen =
if not keep_asm then remove_file asm_filename;
raise exn
end;
if Proc.assemble_file asm_filename obj_filename <> 0
let assemble_result =
Timings.(time (Assemble source_provenance))
(Proc.assemble_file asm_filename) obj_filename
in
if assemble_result <> 0
then raise(Error(Assembler_error asm_filename));
if create_asm && not keep_asm then remove_file asm_filename
with exn ->
remove_file obj_filename;
raise exn
let gen_implementation ?toplevel ppf (size, lam) =
let gen_implementation ?toplevel ~source_provenance ppf (size, lam) =
Emit.begin_assembly ();
Closure.intro size lam
Timings.(time (Clambda source_provenance)) (Closure.intro size) lam
++ clambda_dump_if ppf
++ Cmmgen.compunit size
++ List.iter (compile_phrase ppf) ++ (fun () -> ());
++ Timings.(time (Cmm source_provenance)) (Cmmgen.compunit size)
++ Timings.(time (Compile_phrases source_provenance))
(List.iter (compile_phrase ppf))
++ (fun () -> ());
(match toplevel with None -> () | Some f -> compile_genfuns ppf f);
(* We add explicit references to external primitive symbols. This
@ -140,14 +147,14 @@ let gen_implementation ?toplevel ppf (size, lam) =
);
Emit.end_assembly ()
let compile_implementation ?toplevel prefixname ppf (size, lam) =
let compile_implementation ?toplevel ~source_provenance prefixname ppf (size, lam) =
let asmfile =
if !keep_asm_file || !Emitaux.binary_backend_available
then prefixname ^ ext_asm
else Filename.temp_file "camlasm" ext_asm
in
compile_unit asmfile !keep_asm_file (prefixname ^ ext_obj)
(fun () -> gen_implementation ?toplevel ppf (size, lam))
compile_unit ~source_provenance asmfile !keep_asm_file (prefixname ^ ext_obj)
(fun () -> gen_implementation ?toplevel ~source_provenance ppf (size, lam))
(* Error report *)

2
asmcomp/asmgen.mli
View File

@ -14,6 +14,7 @@
val compile_implementation :
?toplevel:(string -> bool) ->
source_provenance:Timings.source_provenance ->
string -> Format.formatter -> int * Lambda.lambda -> unit
val compile_phrase :
Format.formatter -> Cmm.phrase -> unit
@ -24,5 +25,6 @@ val report_error: Format.formatter -> error -> unit
val compile_unit:
source_provenance:Timings.source_provenance ->
string(*asm file*) -> bool(*keep asm*) ->
string(*obj file*) -> (unit -> unit) -> unit

9
asmcomp/asmlink.ml
View File

@ -203,7 +203,8 @@ let scan_file obj_name tolink = match read_file obj_name with
let make_startup_file ppf units_list =
let compile_phrase p = Asmgen.compile_phrase ppf p in
Location.input_name := "caml_startup"; (* set name of "current" input *)
Compilenv.reset "_startup"; (* set the name of the "current" compunit *)
Compilenv.reset ~source_provenance:Timings.Startup "_startup";
(* set the name of the "current" compunit *)
Emit.begin_assembly ();
let name_list =
List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in
@ -236,7 +237,7 @@ let make_startup_file ppf units_list =
let make_shared_startup_file ppf units =
let compile_phrase p = Asmgen.compile_phrase ppf p in
Location.input_name := "caml_startup";
Compilenv.reset "_shared_startup";
Compilenv.reset ~source_provenance:Timings.Startup "_shared_startup";
Emit.begin_assembly ();
List.iter compile_phrase
(Cmmgen.generic_functions true (List.map fst units));
@ -267,7 +268,7 @@ let link_shared ppf objfiles output_name =
then output_name ^ ".startup" ^ ext_asm
else Filename.temp_file "camlstartup" ext_asm in
let startup_obj = output_name ^ ".startup" ^ ext_obj in
Asmgen.compile_unit
Asmgen.compile_unit ~source_provenance:Timings.Startup
startup !Clflags.keep_startup_file startup_obj
(fun () ->
make_shared_startup_file ppf
@ -326,7 +327,7 @@ let link ppf objfiles output_name =
then output_name ^ ".startup" ^ ext_asm
else Filename.temp_file "camlstartup" ext_asm in
let startup_obj = Filename.temp_file "camlstartup" ext_obj in
Asmgen.compile_unit
Asmgen.compile_unit ~source_provenance:Timings.Startup
startup !Clflags.keep_startup_file startup_obj
(fun () -> make_startup_file ppf units_tolink);
Misc.try_finally

5
asmcomp/asmpackager.ml
View File

@ -91,7 +91,7 @@ let make_package_object ppf members targetobj targetname coercion =
| PM_intf -> None
| PM_impl _ -> Some(Ident.create_persistent m.pm_name))
members in
Asmgen.compile_implementation
Asmgen.compile_implementation ~source_provenance:(Timings.Pack targetname)
(chop_extension_if_any objtemp) ppf
(Translmod.transl_store_package
components (Ident.create_persistent targetname) coercion);
@ -175,7 +175,8 @@ let package_files ppf initial_env files targetcmx =
(* Set the name of the current "input" *)
Location.input_name := targetcmx;
(* Set the name of the current compunit *)
Compilenv.reset ?packname:!Clflags.for_package targetname;
Compilenv.reset ~source_provenance:(Timings.Pack targetname)
?packname:!Clflags.for_package targetname;
try
let coercion =
Typemod.package_units initial_env files targetcmi targetname in

549
asmcomp/build_export_info.ml Normal file
View File

@ -0,0 +1,549 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
module Env : sig
type t
val new_descr : t -> Export_info.descr -> Export_id.t
val record_descr : t -> Export_id.t -> Export_info.descr -> unit
val get_descr : t -> Export_info.approx -> Export_info.descr option
val add_approx : t -> Variable.t -> Export_info.approx -> t
val add_approx_maps : t -> Export_info.approx Variable.Map.t list -> t
val find_approx : t -> Variable.t -> Export_info.approx
val get_symbol_descr : t -> Symbol.t -> Export_info.descr option
val new_unit_descr : t -> Export_id.t
module Global : sig
(* "Global" as in "without local variable bindings". *)
type t
val create_empty : unit -> t
val add_symbol : t -> Symbol.t -> Export_id.t -> t
val new_symbol : t -> Symbol.t -> Export_id.t * t
val symbol_to_export_id_map : t -> Export_id.t Symbol.Map.t
val export_id_to_descr_map : t -> Export_info.descr Export_id.Map.t
end
(** Creates a new environment, sharing the mapping from export IDs to
export descriptions with the given global environment. *)
val empty_of_global : Global.t -> t
end = struct
let fresh_id () = Export_id.create (Compilenv.current_unit ())
module Global = struct
type t =
{ sym : Export_id.t Symbol.Map.t;
(* Note that [ex_table]s themselves are shared (hence [ref] and not
[mutable]). *)
ex_table : Export_info.descr Export_id.Map.t ref;
}
let create_empty () =
{ sym = Symbol.Map.empty;
ex_table = ref Export_id.Map.empty;
}
let add_symbol t sym export_id =
if Symbol.Map.mem sym t.sym then begin
Misc.fatal_errorf "Build_export_info.Env.Global.add_symbol: cannot \
rebind symbol %a in environment"
Symbol.print sym
end;
{ t with sym = Symbol.Map.add sym export_id t.sym }
let new_symbol t sym =
let export_id = fresh_id () in
export_id, add_symbol t sym export_id
let symbol_to_export_id_map t = t.sym
let export_id_to_descr_map t = !(t.ex_table)
end
(* CR-someday mshinwell: The half-mutable nature of [t] with sharing of
the [ex_table] is kind of nasty. Consider making it immutable. *)
type t =
{ var : Export_info.approx Variable.Map.t;
sym : Export_id.t Symbol.Map.t;
ex_table : Export_info.descr Export_id.Map.t ref;
}
let empty_of_global (env : Global.t) =
{ var = Variable.Map.empty;
sym = env.sym;
ex_table = env.ex_table;
}
let extern_id_descr export_id =
let export = Compilenv.approx_env () in
try Some (Export_info.find_description export export_id)
with Not_found -> None
let extern_symbol_descr sym =
if Compilenv.is_predefined_exception sym
then None
else
let export = Compilenv.approx_for_global (Symbol.compilation_unit sym) in
try
let id = Symbol.Map.find sym export.symbol_id in
let descr = Export_info.find_description export id in
Some descr
with
| Not_found -> None
let get_id_descr t export_id =
try Some (Export_id.Map.find export_id !(t.ex_table))
with Not_found -> extern_id_descr export_id
let get_symbol_descr t sym =
try
let export_id = Symbol.Map.find sym t.sym in
Some (Export_id.Map.find export_id !(t.ex_table))
with
| Not_found -> extern_symbol_descr sym
let get_descr t (approx : Export_info.approx) =
match approx with
| Value_unknown -> None
| Value_id export_id -> get_id_descr t export_id
| Value_symbol sym -> get_symbol_descr t sym
let record_descr t id (descr : Export_info.descr) =
if Export_id.Map.mem id !(t.ex_table) then begin
Misc.fatal_errorf "Build_export_info.Env.record_descr: cannot rebind \
export ID %a in environment"
Export_id.print id
end;
t.ex_table := Export_id.Map.add id descr !(t.ex_table)
let new_descr t (descr : Export_info.descr) =
let id = fresh_id () in
record_descr t id descr;
id
let new_unit_descr t =
new_descr t (Value_constptr 0)
let add_approx t var approx =
if Variable.Map.mem var t.var then begin
Misc.fatal_errorf "Build_export_info.Env.add_approx: cannot rebind \
variable %a in environment"
Variable.print var
end;
{ t with var = Variable.Map.add var approx t.var; }
let add_approx_map t vars_to_approxs =
Variable.Map.fold (fun var approx t -> add_approx t var approx)
vars_to_approxs
t
let add_approx_maps t vars_to_approxs_list =
List.fold_left add_approx_map t vars_to_approxs_list
let find_approx t var : Export_info.approx =
try Variable.Map.find var t.var with
| Not_found -> Value_unknown
end
let descr_of_constant (c : Flambda.const) : Export_info.descr =
match c with
(* [Const_pointer] is an immediate value of a type whose values may be
boxed (typically a variant type with both constant and non-constant
constructors). *)
| Int i -> Value_int i
| Char c -> Value_char c
| Const_pointer i -> Value_constptr i
let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr =
match c with
| Float f -> Value_float f
| Int32 i -> Value_boxed_int (Int32, i)
| Int64 i -> Value_boxed_int (Int64, i)
| Nativeint i -> Value_boxed_int (Nativeint, i)
| String s ->
let v_string : Export_info.value_string =
{ size = String.length s; contents = Unknown_or_mutable; }
in
Value_string v_string
| Immutable_string s ->
let v_string : Export_info.value_string =
{ size = String.length s; contents = Contents s; }
in
Value_string v_string
| Immutable_float_array fs ->
Value_float_array {
contents = Contents (Array.map (fun x -> Some x) (Array.of_list fs));
size = List.length fs;
}
| Float_array fs ->
Value_float_array {
contents = Unknown_or_mutable;
size = List.length fs;
}
let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx =
match flam with
| Var var -> Env.find_approx env var
| Let { var; defining_expr; body; _ } ->
let approx = descr_of_named env defining_expr in
let env = Env.add_approx env var approx in
approx_of_expr env body
| Let_mutable (_mut_var, _var, body) ->
approx_of_expr env body
| Let_rec (defs, body) ->
let env =
List.fold_left (fun env (var, defining_expr) ->
let approx = descr_of_named env defining_expr in
Env.add_approx env var approx)
env defs
in
approx_of_expr env body
| Apply { func; kind; _ } ->
begin match kind with
| Indirect -> Value_unknown
| Direct closure_id' ->
match Env.get_descr env (Env.find_approx env func) with
| Some (Value_closure
{ closure_id; set_of_closures = { results; _ }; }) ->
assert (Closure_id.equal closure_id closure_id');
assert (Closure_id.Map.mem closure_id results);
Closure_id.Map.find closure_id results
| _ -> Value_unknown
end
| Assign _ -> Value_id (Env.new_unit_descr env)
| For _ -> Value_id (Env.new_unit_descr env)
| While _ -> Value_id (Env.new_unit_descr env)
| Static_raise _ | Static_catch _ | Try_with _ | If_then_else _
| Switch _ | String_switch _ | Send _ | Proved_unreachable ->
Value_unknown
and descr_of_named (env : Env.t) (named : Flambda.named)
: Export_info.approx =
match named with
| Expr expr -> approx_of_expr env expr
| Symbol sym -> Value_symbol sym
| Read_mutable _ -> Value_unknown
| Read_symbol_field (sym, i) ->
begin match Env.get_symbol_descr env sym with
| Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
| _ -> Value_unknown
end
| Const const ->
Value_id (Env.new_descr env (descr_of_constant const))
| Allocated_const const ->
Value_id (Env.new_descr env (descr_of_allocated_constant const))
| Prim (Pmakeblock (tag, Immutable), args, _dbg) ->
let approxs = List.map (Env.find_approx env) args in
let descr : Export_info.descr =
Value_block (Tag.create_exn tag, Array.of_list approxs)
in
Value_id (Env.new_descr env descr)
| Prim (Pfield i, [arg], _) ->
begin match Env.get_descr env (Env.find_approx env arg) with
| Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
| _ -> Value_unknown
end
| Prim (Pgetglobal id, _, _) ->
Value_symbol (Compilenv.symbol_for_global' id)
| Prim _ -> Value_unknown
| Set_of_closures set ->
let descr : Export_info.descr =
Value_set_of_closures (describe_set_of_closures env set)
in
Value_id (Env.new_descr env descr)
| Project_closure { set_of_closures; closure_id; } ->
begin match Env.get_descr env (Env.find_approx env set_of_closures) with
| Some (Value_set_of_closures set_of_closures) ->
if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin
Misc.fatal_errorf "Could not build export description for \
[Project_closure]: closure ID %a not in set of closures"
Closure_id.print closure_id
end;
let descr : Export_info.descr =
Value_closure { closure_id = closure_id; set_of_closures; }
in
Value_id (Env.new_descr env descr)
| _ ->
(* CR pchambart: This should be [assert false], but currently there are a
few cases where this is less precise than inline_and_simplify.
mshinwell: Can you elaborate? *)
Value_unknown
end
| Move_within_set_of_closures { closure; start_from; move_to; } ->
begin match Env.get_descr env (Env.find_approx env closure) with
| Some (Value_closure { set_of_closures; closure_id; }) ->
assert (Closure_id.equal closure_id start_from);
let descr : Export_info.descr =
Value_closure { closure_id = move_to; set_of_closures; }
in
Value_id (Env.new_descr env descr)
| _ -> Value_unknown
end
| Project_var { closure; closure_id = closure_id'; var; } ->
begin match Env.get_descr env (Env.find_approx env closure) with
| Some (Value_closure
{ set_of_closures = { bound_vars; _ }; closure_id; }) ->
assert (Closure_id.equal closure_id closure_id');
if not (Var_within_closure.Map.mem var bound_vars) then begin
Misc.fatal_errorf "Project_var from %a (closure ID %a) of \
variable %a that is not bound by the closure. \
Variables bound by the closure are: %a"
Variable.print closure
Closure_id.print closure_id
Var_within_closure.print var
(Var_within_closure.Map.print (fun _ _ -> ())) bound_vars
end;
Var_within_closure.Map.find var bound_vars
| _ -> Value_unknown
end
and describe_set_of_closures env (set : Flambda.set_of_closures)
: Export_info.value_set_of_closures =
let bound_vars_approx =
Variable.Map.map (Env.find_approx env) set.free_vars
in
let specialised_args_approx =
Variable.Map.map (Env.find_approx env) set.specialised_args
in
let closures_approx =
(* To build an approximation of the results, we need an
approximation of the functions. The first one we can build is
one where every function returns something unknown.
*)
(* CR-someday pchambart: we could improve a bit on that by building a
recursive approximation of the closures: The value_closure
description contains a [value_set_of_closures]. We could replace
this field by a [Expr_id.t] or an [approx].
mshinwell: Deferred for now.
*)
let initial_value_set_of_closures =
{ Export_info.
set_of_closures_id = set.function_decls.set_of_closures_id;
bound_vars = Var_within_closure.wrap_map bound_vars_approx;
results =
Closure_id.wrap_map
(Variable.Map.map (fun _ -> Export_info.Value_unknown)
set.function_decls.funs);
aliased_symbol = None;
}
in
Variable.Map.mapi (fun fun_var _function_decl ->
let descr : Export_info.descr =
Value_closure
{ closure_id = Closure_id.wrap fun_var;
set_of_closures = initial_value_set_of_closures;
}
in
Export_info.Value_id (Env.new_descr env descr))
set.function_decls.funs
in
let closure_env =
Env.add_approx_maps env
[closures_approx; bound_vars_approx; specialised_args_approx]
in
let results =
let result_approx _var (function_decl : Flambda.function_declaration) =
approx_of_expr closure_env function_decl.body
in
Variable.Map.mapi result_approx set.function_decls.funs
in
{ set_of_closures_id = set.function_decls.set_of_closures_id;
bound_vars = Var_within_closure.wrap_map bound_vars_approx;
results = Closure_id.wrap_map results;
aliased_symbol = None;
}
let approx_of_constant_defining_value_block_field env
(c : Flambda.constant_defining_value_block_field) : Export_info.approx =
match c with
| Symbol s -> Value_symbol s
| Const c -> Value_id (Env.new_descr env (descr_of_constant c))
let describe_constant_defining_value env export_id symbol
(const : Flambda.constant_defining_value) =
let env =
(* Assignments of variables to export IDs are local to each constant
defining value. *)
Env.empty_of_global env
in
match const with
| Allocated_const alloc_const ->
let descr = descr_of_allocated_constant alloc_const in
Env.record_descr env export_id descr
| Block (tag, fields) ->
let approxs =
List.map (approx_of_constant_defining_value_block_field env) fields
in
Env.record_descr env export_id (Value_block (tag, Array.of_list approxs))
| Set_of_closures set_of_closures ->
let descr : Export_info.descr =
Value_set_of_closures
{ (describe_set_of_closures env set_of_closures) with
aliased_symbol = Some symbol;
}
in
Env.record_descr env export_id descr
| Project_closure (sym, closure_id) ->
begin match Env.get_symbol_descr env sym with
| Some (Value_set_of_closures set_of_closures) ->
if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin
Misc.fatal_errorf "Could not build export description for \
[Project_closure] constant defining value: closure ID %a not in \
set of closures"
Closure_id.print closure_id
end;
let descr =
Export_info.Value_closure
{ closure_id = closure_id; set_of_closures; }
in
Env.record_descr env export_id descr
| None ->
Misc.fatal_errorf
"Cannot project symbol %a to closure_id %a. \
No available export description@."
Symbol.print sym
Closure_id.print closure_id
| Some (Value_closure _) ->
Misc.fatal_errorf
"Cannot project symbol %a to closure_id %a. \
The symbol is a closure instead of a set of closures.@."
Symbol.print sym
Closure_id.print closure_id
| Some _ ->
Misc.fatal_errorf
"Cannot project symbol %a to closure_id %a. \
The symbol is not a set of closures.@."
Symbol.print sym
Closure_id.print closure_id
end
let describe_program (env : Env.Global.t) (program : Flambda.program) =
let rec loop env (program : Flambda.program_body) =
match program with
| Let_symbol (symbol, constant_defining_value, program) ->
let id, env = Env.Global.new_symbol env symbol in
describe_constant_defining_value env id symbol constant_defining_value;
loop env program
| Let_rec_symbol (defs, program) ->
let env, defs =
List.fold_left (fun (env, defs) (symbol, def) ->
let id, env = Env.Global.new_symbol env symbol in
env, ((id, symbol, def) :: defs))
(env, []) defs
in
(* [Project_closure]s are separated to be handled last. They are the
only values that need a description for their argument. *)
let project_closures, other_constants =
List.partition (function
| _, _, Flambda.Project_closure _ -> true
| _ -> false)
defs
in
List.iter (fun (id, symbol, def) ->
describe_constant_defining_value env id symbol def)
other_constants;
List.iter (fun (id, symbol, def) ->
describe_constant_defining_value env id symbol def)
project_closures;
loop env program
| Initialize_symbol (symbol, tag, fields, program) ->
let id =
let env =
(* Assignments of variables to export IDs are local to each
[Initialize_symbol] construction. *)
Env.empty_of_global env
in
let field_approxs = List.map (approx_of_expr env) fields in
let descr : Export_info.descr =
Value_block (tag, Array.of_list field_approxs)
in
Env.new_descr env descr
in
let env = Env.Global.add_symbol env symbol id in
loop env program
| Effect (_expr, program) -> loop env program
| End symbol -> symbol, env
in
loop env program.program_body
let build_export_info ~(backend : (module Backend_intf.S))
(program : Flambda.program) : Export_info.t =
if !Clflags.opaque then
Export_info.empty
else
(* CR pchambart: Should probably use that instead of the ident of
the module as global identifier.
mshinwell: Is "that" the variable "_global_symbol"? *)
let _global_symbol, env =
describe_program (Env.Global.create_empty ()) program
in
let globals =
let root_approx : Export_info.approx =
Value_symbol (Compilenv.current_unit_symbol ())
in
Ident.Map.singleton (Compilenv.current_unit_id ()) root_approx
in
let sets_of_closures =
Flambda_utils.all_function_decls_indexed_by_set_of_closures_id program
in
let closures =
Flambda_utils.all_function_decls_indexed_by_closure_id program
in
let invariant_params =
Set_of_closures_id.Map.map
(fun { Flambda. function_decls; _ } ->
Invariant_params.invariant_params_in_recursion
~backend function_decls)
(Flambda_utils.all_sets_of_closures_map program)
in
let unnested_values =
Env.Global.export_id_to_descr_map env
in
let invariant_params =
let export = Compilenv.approx_env () in
Export_id.Map.fold (fun _eid (descr:Export_info.descr)
(invariant_params) ->
match descr with
| Value_closure { set_of_closures }
| Value_set_of_closures set_of_closures ->
let { Export_info.set_of_closures_id } = set_of_closures in
begin match
Set_of_closures_id.Map.find set_of_closures_id
export.invariant_params
with
| exception Not_found ->
invariant_params
| (set:Variable.Set.t Variable.Map.t) ->
Set_of_closures_id.Map.add set_of_closures_id set invariant_params
end
| _ ->
invariant_params)
unnested_values invariant_params
in
let values =
Export_info.nest_eid_map unnested_values
in
Export_info.create ~values ~globals
~symbol_id:(Env.Global.symbol_to_export_id_map env)
~offset_fun:Closure_id.Map.empty
~offset_fv:Var_within_closure.Map.empty
~sets_of_closures ~closures
~constant_sets_of_closures:Set_of_closures_id.Set.empty
~invariant_params

23
asmcomp/build_export_info.mli Normal file
View File

@ -0,0 +1,23 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Construct export information, for emission into .cmx files, from an
Flambda program. *)
val build_export_info :
backend:(module Backend_intf.S) ->
Flambda.program ->
Export_info.t

14
asmcomp/clambda.ml
View File

@ -26,13 +26,14 @@ type ustructured_constant =
| Uconst_block of int * uconstant list
| Uconst_float_array of float list
| Uconst_string of string
| Uconst_closure of ufunction list * string * uconstant list
and uconstant =
| Uconst_ref of string * ustructured_constant
| Uconst_ref of string * ustructured_constant option
| Uconst_int of int
| Uconst_ptr of int
type ulambda =
and ulambda =
Uvar of Ident.t
| Uconst of uconstant
| Udirect_apply of function_label * ulambda list * Debuginfo.t
@ -53,6 +54,7 @@ type ulambda =
| Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
| Uassign of Ident.t * ulambda
| Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
| Uunreachable
and ufunction = {
label : function_label;
@ -133,6 +135,7 @@ let rank_structured_constant = function
| Uconst_block _ -> 4
| Uconst_float_array _ -> 5
| Uconst_string _ -> 6
| Uconst_closure _ -> 7
let compare_structured_constants c1 c2 =
match c1, c2 with
@ -146,5 +149,8 @@ let compare_structured_constants c1 c2 =
| Uconst_float_array l1, Uconst_float_array l2 ->
compare_float_lists l1 l2
| Uconst_string s1, Uconst_string s2 -> String.compare s1 s2
| _, _ -> rank_structured_constant c1 - rank_structured_constant c2
(* no overflow possible here *)
| Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) ->
String.compare lbl1 lbl2
| _, _ ->
(* no overflow possible here *)
rank_structured_constant c1 - rank_structured_constant c2

6
asmcomp/clambda.mli
View File

@ -26,13 +26,14 @@ type ustructured_constant =
| Uconst_block of int * uconstant list
| Uconst_float_array of float list
| Uconst_string of string
| Uconst_closure of ufunction list * string * uconstant list
and uconstant =
| Uconst_ref of string * ustructured_constant
| Uconst_ref of string * ustructured_constant option
| Uconst_int of int
| Uconst_ptr of int
type ulambda =
and ulambda =
Uvar of Ident.t
| Uconst of uconstant
| Udirect_apply of function_label * ulambda list * Debuginfo.t
@ -53,6 +54,7 @@ type ulambda =
| Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
| Uassign of Ident.t * ulambda
| Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
| Uunreachable
and ufunction = {
label : function_label;

60
asmcomp/closure.ml
View File

@ -83,6 +83,7 @@ let occurs_var var u =
| Uassign(id, u) -> id = var || occurs u
| Usend(_, met, obj, args, _) ->
occurs met || occurs obj || List.exists occurs args
| Uunreachable -> false
and occurs_array a =
try
for i = 0 to Array.length a - 1 do
@ -235,6 +236,7 @@ let lambda_smaller lam threshold =
| Usend(_, met, obj, args, _) ->
size := !size + 8;
lambda_size met; lambda_size obj; lambda_list_size args
| Uunreachable -> ()
and lambda_list_size l = List.iter lambda_size l
and lambda_array_size a = Array.iter lambda_size a in
try
@ -258,7 +260,7 @@ let rec is_pure_clambda = function
let make_const c = (Uconst c, Value_const c)
let make_const_ref c =
make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, c))
make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, Some c))
let make_const_int n = make_const (Uconst_int n)
let make_const_ptr n = make_const (Uconst_ptr n)
let make_const_bool b = make_const_ptr(if b then 1 else 0)
@ -320,7 +322,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* float *)
| [Value_const(Uconst_ref(_, Uconst_float n1))] when fpc ->
| [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc ->
begin match p with
| Pintoffloat -> make_const_int (int_of_float n1)
| Pnegfloat -> make_const_float (-. n1)
@ -328,8 +330,8 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* float, float *)
| [Value_const(Uconst_ref(_, Uconst_float n1));
Value_const(Uconst_ref(_, Uconst_float n2))] when fpc ->
| [Value_const(Uconst_ref(_, Some (Uconst_float n1)));
Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc ->
begin match p with
| Paddfloat -> make_const_float (n1 +. n2)
| Psubfloat -> make_const_float (n1 -. n2)
@ -339,7 +341,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* nativeint *)
| [Value_const(Uconst_ref(_, Uconst_nativeint n))] ->
| [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] ->
begin match p with
| Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n)
| Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n)
@ -348,8 +350,8 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* nativeint, nativeint *)
| [Value_const(Uconst_ref(_, Uconst_nativeint n1));
Value_const(Uconst_ref(_, Uconst_nativeint n2))] ->
| [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));
Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] ->
begin match p with
| Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2)
| Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2)
@ -365,7 +367,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* nativeint, int *)
| [Value_const(Uconst_ref(_, Uconst_nativeint n1));
| [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));
Value_const(Uconst_int n2)] ->
begin match p with
| Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
@ -377,7 +379,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* int32 *)
| [Value_const(Uconst_ref(_, Uconst_int32 n))] ->
| [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] ->
begin match p with
| Pintofbint Pint32 -> make_const_int (Int32.to_int n)
| Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n)
@ -386,8 +388,8 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* int32, int32 *)
| [Value_const(Uconst_ref(_, Uconst_int32 n1));
Value_const(Uconst_ref(_, Uconst_int32 n2))] ->
| [Value_const(Uconst_ref(_, Some (Uconst_int32 n1)));
Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] ->
begin match p with
| Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2)
| Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2)
@ -401,7 +403,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* int32, int *)
| [Value_const(Uconst_ref(_, Uconst_int32 n1));
| [Value_const(Uconst_ref(_, Some (Uconst_int32 n1)));
Value_const(Uconst_int n2)] ->
begin match p with
| Plslbint Pint32 when 0 <= n2 && n2 < 32 ->
@ -413,7 +415,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* int64 *)
| [Value_const(Uconst_ref(_, Uconst_int64 n))] ->
| [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] ->
begin match p with
| Pintofbint Pint64 -> make_const_int (Int64.to_int n)
| Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n)
@ -422,8 +424,8 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* int64, int64 *)
| [Value_const(Uconst_ref(_, Uconst_int64 n1));
Value_const(Uconst_ref(_, Uconst_int64 n2))] ->
| [Value_const(Uconst_ref(_, Some (Uconst_int64 n1)));
Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] ->
begin match p with
| Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2)
| Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2)
@ -437,7 +439,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
| _ -> default
end
(* int64, int *)
| [Value_const(Uconst_ref(_, Uconst_int64 n1));
| [Value_const(Uconst_ref(_, Some (Uconst_int64 n1)));
Value_const(Uconst_int n2)] ->
begin match p with
| Plslbint Pint64 when 0 <= n2 && n2 < 64 ->
@ -455,7 +457,8 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
let field_approx n = function
| Value_tuple a when n < Array.length a -> a.(n)
| Value_const (Uconst_ref(_, Uconst_block(_, l))) when n < List.length l ->
| Value_const (Uconst_ref(_, Some (Uconst_block(_, l))))
when n < List.length l ->
Value_const (List.nth l n)
| _ -> Value_unknown
@ -472,19 +475,19 @@ let simplif_prim_pure fpc p (args, approxs) dbg =
let name =
Compilenv.new_structured_constant cst ~shared:true
in
make_const (Uconst_ref (name, cst))
make_const (Uconst_ref (name, Some cst))
with Exit ->
(Uprim(p, args, dbg), Value_tuple (Array.of_list approxs))
end
(* Field access *)
| Pfield n, _, [ Value_const(Uconst_ref(_, Uconst_block(_, l))) ]
| Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]
when n < List.length l ->
make_const (List.nth l n)
| Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx]
when n < List.length ul ->
(List.nth ul n, field_approx n approx)
(* Strings *)
| Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] ->
| Pstringlength, _, [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] ->
make_const_int (String.length s)
(* Identity *)
| Pidentity, [arg1], [app1] ->
@ -602,7 +605,7 @@ let rec substitute fpc sb ulam =
in this substitute function.
*)
match sarg with
| Uconst (Uconst_ref (_, Uconst_block (tag, _))) ->
| Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) ->
find_action sw.us_index_blocks sw.us_actions_blocks tag
| Uconst (Uconst_ptr tag) ->
find_action sw.us_index_consts sw.us_actions_consts tag
@ -665,6 +668,8 @@ let rec substitute fpc sb ulam =
| Usend(k, u1, u2, ul, dbg) ->
Usend(k, substitute fpc sb u1, substitute fpc sb u2,
List.map (substitute fpc sb) ul, dbg)
| Uunreachable ->
Uunreachable
(* Perform an inline expansion *)
@ -838,7 +843,7 @@ let rec close fenv cenv = function
let name =
Compilenv.new_structured_constant cst ~shared
in
Uconst_ref (name, cst)
Uconst_ref (name, Some cst)
in
let rec transl = function
| Const_base(Const_int n) -> Uconst_int n
@ -1313,15 +1318,17 @@ let collect_exported_structured_constants a =
| Value_const c -> const c
| Value_unknown | Value_global_field _ -> ()
and const = function
| Uconst_ref (s, c) ->
| Uconst_ref (s, (Some c)) ->
Compilenv.add_exported_constant s;
structured_constant c
| Uconst_ref (s, None) -> assert false (* Cannot be generated *)
| Uconst_int _ | Uconst_ptr _ -> ()
and structured_constant = function
| Uconst_block (_, ul) -> List.iter const ul
| Uconst_float _ | Uconst_int32 _
| Uconst_int64 _ | Uconst_nativeint _
| Uconst_float_array _ | Uconst_string _ -> ()
| Uconst_closure _ -> assert false (* Cannot be generated *)
and ulam = function
| Uvar _ -> ()
| Uconst c -> const c
@ -1351,6 +1358,7 @@ let collect_exported_structured_constants a =
| Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3
| Uassign (_, u) -> ulam u
| Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul
| Uunreachable -> ()
in
approx a
@ -1366,7 +1374,11 @@ let intro size lam =
global_approx := Array.init size (fun i -> Value_global_field (id, i));
Compilenv.set_global_approx(Value_tuple !global_approx);
let (ulam, approx) = close Tbl.empty Tbl.empty lam in
if !Clflags.opaque
let opaque =
!Clflags.opaque
|| Env.is_imported_opaque (Compilenv.current_unit_name ())
in
if opaque
then Compilenv.set_global_approx(Value_unknown)
else collect_exported_structured_constants (Value_tuple !global_approx);
global_approx := [||];

136
asmcomp/closure_offsets.ml Normal file
View File

@ -0,0 +1,136 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 result = {
function_offsets : int Closure_id.Map.t;
free_variable_offsets : int Var_within_closure.Map.t;
}
let add_closure_offsets
{ function_offsets; free_variable_offsets }
({ function_decls; free_vars } : Flambda.set_of_closures) =
(* Build the table mapping the functions declared by the set of closures
to the positions of their individual "infix" closures inside the runtime
closure block. (All of the environment entries will come afterwards.) *)
let assign_function_offset id function_decl (map, env_pos) =
let pos = env_pos + 1 in
let env_pos =
let arity = Flambda_utils.function_arity function_decl in
env_pos
+ 1 (* GC header; either [Closure_tag] or [Infix_tag] *)
+ 1 (* full application code pointer *)
+ 1 (* arity *)
+ (if arity > 1 then 1 else 0) (* partial application code pointer *)
in
let closure_id = Closure_id.wrap id in
if Closure_id.Map.mem closure_id map then begin
Misc.fatal_errorf "Closure_offsets.add_closure_offsets: function \
offset for %a would be defined multiple times"
Closure_id.print closure_id
end;
let map = Closure_id.Map.add closure_id pos map in
(map, env_pos)
in
let function_offsets, free_variable_pos =
Variable.Map.fold assign_function_offset
function_decls.funs (function_offsets, -1)
in
(* Adds the mapping of free variables to their offset. Recall that
projections of [Var_within_closure]s are only currently used when
compiling accesses to the closure of a function from outside that
function (in particular, as a result of inlining). Accesses to
a function's own closure are compiled directly via normal [Var]
accesses. *)
(* CR-someday mshinwell: As discussed with lwhite, maybe this isn't
ideal, and the self accesses should be explicitly marked too. *)
let assign_free_variable_offset var _ (map, pos) =
let var_within_closure = Var_within_closure.wrap var in
if Var_within_closure.Map.mem var_within_closure map then begin
Misc.fatal_errorf "Closure_offsets.add_closure_offsets: free variable \
offset for %a would be defined multiple times"
Var_within_closure.print var_within_closure
end;
let map = Var_within_closure.Map.add var_within_closure pos map in
(map, pos + 1)
in
let free_variable_offsets, _ =
Variable.Map.fold assign_free_variable_offset
free_vars (free_variable_offsets, free_variable_pos)
in
{ function_offsets;
free_variable_offsets;
}
let compute (program:Flambda.program) =
let init : result =
{ function_offsets = Closure_id.Map.empty;
free_variable_offsets = Var_within_closure.Map.empty;
}
in
let r =
List.fold_left add_closure_offsets
init (Flambda_utils.all_sets_of_closures program)
in
r
let compute_reexported_offsets program
~current_unit_offset_fun ~current_unit_offset_fv
~imported_units_offset_fun ~imported_units_offset_fv =
let offset_fun = ref current_unit_offset_fun in
let offset_fv = ref current_unit_offset_fv in
let used_closure_id closure_id =
match Closure_id.Map.find closure_id imported_units_offset_fun with
| offset ->
assert (not (Closure_id.Map.mem closure_id current_unit_offset_fun));
begin match Closure_id.Map.find closure_id !offset_fun with
| exception Not_found ->
offset_fun := Closure_id.Map.add closure_id offset !offset_fun
| offset' -> assert (offset = offset')
end
| exception Not_found ->
assert (Closure_id.Map.mem closure_id current_unit_offset_fun)
in
let used_var_within_closure var =
match Var_within_closure.Map.find var imported_units_offset_fv with
| offset ->
assert (not (Var_within_closure.Map.mem var current_unit_offset_fv));
begin match Var_within_closure.Map.find var !offset_fv with
| exception Not_found ->
offset_fv := Var_within_closure.Map.add var offset !offset_fv
| offset' -> assert (offset = offset')
end
| exception Not_found ->
assert (Var_within_closure.Map.mem var current_unit_offset_fv)
in
Flambda_iterators.iter_named_of_program program
~f:(fun (named : Flambda.named) ->
match named with
| Project_closure { closure_id; _ } ->
used_closure_id closure_id
| Move_within_set_of_closures { start_from; move_to; _ } ->
used_closure_id start_from;
used_closure_id move_to
| Project_var { closure_id; var; _ } ->
used_closure_id closure_id;
used_var_within_closure var
| Symbol _ | Const _ | Allocated_const _ | Read_mutable _
| Read_symbol_field _ | Set_of_closures _ | Prim _ | Expr _ -> ());
Flambda_iterators.iter_constant_defining_values_on_program program
~f:(fun (const : Flambda.constant_defining_value) ->
match const with
| Project_closure (_, closure_id) -> used_closure_id closure_id
| Allocated_const _ | Block _ | Set_of_closures _ -> ());
!offset_fun, !offset_fv

42
asmcomp/closure_offsets.mli Normal file
View File

@ -0,0 +1,42 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Assign numerical offsets, within closure blocks, for code pointers and
environment entries. *)
type result = private {
function_offsets : int Closure_id.Map.t;
free_variable_offsets : int Var_within_closure.Map.t;
}
val compute : Flambda.program -> result
(** If compilation unit [C] references [B], which contains functions inlined
from another compilation unit [A], then we may need to know the layout of
closures inside (or constructed by code inside) a.cmx in order to
compile c.cmx. Unfortunately a.cmx is permitted to be absent during such
compilation; c.cmx will be compiled using just b.cmx. As such, when
building the .cmx export information for a given compilation unit, we
also include information about the layout of any closures that it depends
on from other compilation units. This means that when situations as just
describe arise, we always have access to the necessary closure offsets. *)
val compute_reexported_offsets
: Flambda.program
-> current_unit_offset_fun:int Closure_id.Map.t
-> current_unit_offset_fv:int Var_within_closure.Map.t
-> imported_units_offset_fun:int Closure_id.Map.t
-> imported_units_offset_fv:int Var_within_closure.Map.t
-> int Closure_id.Map.t * int Var_within_closure.Map.t

65
asmcomp/cmmgen.ml
View File

@ -727,7 +727,7 @@ let transl_structured_constant cst =
(* Translate constant closures *)
let constant_closures =
ref ([] : (string * ufunction list) list)
ref ([] : (string * ufunction list * uconstant list) list)
(* Boxed integers *)
@ -1320,10 +1320,13 @@ let rec is_unboxed_number env e =
| Some (_, bn) -> Boxed bn
end
| Uconst(Uconst_ref(_, Uconst_float _)) -> Boxed Boxed_float
| Uconst(Uconst_ref(_, Uconst_int32 _)) -> Boxed (Boxed_integer Pint32)
| Uconst(Uconst_ref(_, Uconst_int64 _)) -> Boxed (Boxed_integer Pint64)
| Uconst(Uconst_ref(_, Uconst_nativeint _)) ->
| Uconst(Uconst_ref(_, Some (Uconst_float _))) ->
Boxed Boxed_float
| Uconst(Uconst_ref(_, Some (Uconst_int32 _))) ->
Boxed (Boxed_integer Pint32)
| Uconst(Uconst_ref(_, Some (Uconst_int64 _))) ->
Boxed (Boxed_integer Pint64)
| Uconst(Uconst_ref(_, Some (Uconst_nativeint _))) ->
Boxed (Boxed_integer Pnativeint)
| Uprim(p, _, _) ->
begin match simplif_primitive p with
@ -1406,7 +1409,7 @@ let rec transl env e =
transl_constant sc
| Uclosure(fundecls, []) ->
let lbl = Compilenv.new_const_symbol() in
constant_closures := (lbl, fundecls) :: !constant_closures;
constant_closures := (lbl, fundecls, []) :: !constant_closures;
List.iter (fun f -> Queue.add f functions) fundecls;
Cconst_symbol lbl
| Uclosure(fundecls, clos_vars) ->
@ -1644,6 +1647,8 @@ let rec transl env e =
| Some (unboxed_id, bn) ->
return_unit(Cassign(unboxed_id, transl_unbox_number env bn exp))
end
| Uunreachable ->
Cop(Cload Word_int, [Cconst_int 0])
and transl_ccall env prim args dbg =
let transl_arg native_repr arg =
@ -2195,15 +2200,15 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
fatal_error "Cmmgen.transl_prim_3"
and transl_unbox_float env = function
Uconst(Uconst_ref(_, Uconst_float f)) -> Cconst_float f
Uconst(Uconst_ref(_, Some (Uconst_float f))) -> Cconst_float f
| exp -> unbox_float(transl env exp)
and transl_unbox_int env bi = function
Uconst(Uconst_ref(_, Uconst_int32 n)) ->
Uconst(Uconst_ref(_, Some (Uconst_int32 n))) ->
Cconst_natint (Nativeint.of_int32 n)
| Uconst(Uconst_ref(_, Uconst_nativeint n)) ->
| Uconst(Uconst_ref(_, Some (Uconst_nativeint n))) ->
Cconst_natint n
| Uconst(Uconst_ref(_, Uconst_int64 n)) ->
| Uconst(Uconst_ref(_, Some (Uconst_int64 n))) ->
if size_int = 8 then
Cconst_natint (Int64.to_nativeint n)
else
@ -2405,7 +2410,7 @@ let rec transl_all_functions already_translated cont =
(transl_function f :: cont)
end
with Queue.Empty ->
cont
cont, already_translated
(* Emit structured constants *)
@ -2437,6 +2442,10 @@ let rec emit_structured_constant symb cst cont =
| Uconst_float_array fields ->
emit_block (floatarray_header (List.length fields)) symb
(Misc.map_end (fun f -> Cdouble f) fields cont)
| Uconst_closure(fundecls, lbl, fv) ->
constant_closures := (lbl, fundecls, fv) :: !constant_closures;
List.iter (fun f -> Queue.add f functions) fundecls;
cont
and emit_constant cst cont =
match cst with
@ -2474,12 +2483,13 @@ and emit_boxed_int64_constant n cont =
(* Emit constant closures *)
let emit_constant_closure symb fundecls cont =
let emit_constant_closure symb fundecls clos_vars cont =
match fundecls with
[] -> assert false
| f1 :: remainder ->
let rec emit_others pos = function
[] -> cont
[] ->
List.fold_right emit_constant clos_vars cont
| f2 :: rem ->
if f2.arity = 1 then
Cint(infix_header pos) ::
@ -2492,7 +2502,8 @@ let emit_constant_closure symb fundecls cont =
Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) ::
Csymbol_address f2.label ::
emit_others (pos + 4) rem in
Cint(black_closure_header (fundecls_size fundecls)) ::
Cint(black_closure_header (fundecls_size fundecls
+ List.length clos_vars)) ::
Cdefine_symbol symb ::
if f1.arity = 1 then
Csymbol_address f1.label ::
@ -2517,12 +2528,25 @@ let emit_all_constants cont =
c:= Cdata(cst):: !c)
(Compilenv.structured_constants());
List.iter
(fun (symb, fundecls) ->
c := Cdata(emit_constant_closure symb fundecls []) :: !c)
(fun (symb, fundecls, clos_vars) ->
c := Cdata(emit_constant_closure symb fundecls clos_vars []) :: !c)
!constant_closures;
constant_closures := [];
Compilenv.clear_structured_constants ();
!c
let transl_all_functions_and_emit_all_constants cont =
let rec aux already_translated cont =
if Compilenv.structured_constants () = [] &&
Queue.is_empty functions
then cont
else
let cont, set = transl_all_functions already_translated cont in
let cont = emit_all_constants cont in
aux already_translated cont
in
aux StringSet.empty cont
(* Build the table of GC roots for toplevel modules *)
let emit_module_roots_table ~symbols cont =
@ -2542,9 +2566,8 @@ let compunit size ulam =
fun_args = [];
fun_body = init_code; fun_fast = false;
fun_dbg = Debuginfo.none }] in
let c2 = transl_all_functions StringSet.empty c1 in
let c3 = emit_all_constants c2 in
let c4 = emit_module_roots_table ~symbols:[glob] c3 in
let c2 = transl_all_functions_and_emit_all_constants c1 in
let c3 = emit_module_roots_table ~symbols:[glob] c2 in
let space =
(* These words will be registered as roots and as such must contain
valid values, in case we are in no-naked-pointers mode. Likewise
@ -2556,7 +2579,7 @@ let compunit size ulam =
in
Cdata ([Cint(black_block_header 0 size);
Cglobal_symbol glob;
Cdefine_symbol glob] @ space) :: c4
Cdefine_symbol glob] @ space) :: c3
(*
CAMLprim value caml_cache_public_method (value meths, value tag, value *cache)
@ -2945,7 +2968,7 @@ let predef_exception i name =
emit_structured_constant symname
(Uconst_block(Obj.object_tag,
[
Uconst_ref(label, cst);
Uconst_ref(label, Some cst);
Uconst_int (-i-1);
])) cont)

43
asmcomp/compilenv.ml
View File

@ -27,6 +27,8 @@ exception Error of error
let global_infos_table =
(Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
let sourcefile = ref None
module CstMap =
Map.Make(struct
type t = Clambda.ustructured_constant
@ -79,9 +81,10 @@ let symbolname_for_pack pack name =
Buffer.contents b
let reset ?packname name =
let reset ?packname ~source_provenance:file name =
Hashtbl.clear global_infos_table;
let symbol = symbolname_for_pack packname name in
sourcefile := Some file;
current_unit.ui_name <- name;
current_unit.ui_symbol <- symbol;
current_unit.ui_defines <- [symbol];
@ -100,6 +103,11 @@ let current_unit_infos () =
let current_unit_name () =
current_unit.ui_name
let current_build () =
match !sourcefile with
| None -> assert false
| Some v -> v
let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
let prefix = "caml" ^ unitname in
match idopt with
@ -152,15 +160,21 @@ let get_global_info global_ident = (
Hashtbl.find global_infos_table modname
with Not_found ->
let (infos, crc) =
try
let filename =
find_in_path_uncap !load_path (modname ^ ".cmx") in
let (ui, crc) = read_unit_info filename in
if ui.ui_name <> modname then
raise(Error(Illegal_renaming(modname, ui.ui_name, filename)));
(Some ui, Some crc)
with Not_found ->
(None, None) in
if Env.is_imported_opaque modname then (None, None)
else begin
try
let filename =
find_in_path_uncap !load_path (modname ^ ".cmx") in
let (ui, crc) = read_unit_info filename in
if ui.ui_name <> modname then
raise(Error(Illegal_renaming(modname, ui.ui_name, filename)));
(Some ui, Some crc)
with Not_found ->
let warn = Warnings.No_cmx_file modname in
Location.prerr_warning Location.none warn;
(None, None)
end
in
current_unit.ui_imports_cmx <-
(modname, crc) :: current_unit.ui_imports_cmx;
Hashtbl.add global_infos_table modname infos;
@ -192,7 +206,11 @@ let symbol_for_global id =
if Ident.is_predef_exn id then
"caml_exn_" ^ Ident.name id
else begin
match get_global_info id with
let unitname = Ident.name id in
match
try ignore (Hashtbl.find toplevel_approx unitname); None
with Not_found -> get_global_info id
with
| None -> make_symbol ~unitname:(Ident.name id) None
| Some ui -> make_symbol ~unitname:ui.ui_symbol None
end
@ -271,6 +289,9 @@ let new_structured_constant cst ~shared =
let add_exported_constant s =
Hashtbl.replace exported_constants s ()
let clear_structured_constants () =
structured_constants := structured_constants_empty
let structured_constants () =
List.map
(fun (lbl, cst) ->

8
asmcomp/compilenv.mli
View File

@ -14,7 +14,8 @@
open Cmx_format
val reset: ?packname:string -> string -> unit
val reset: ?packname:string -> source_provenance:Timings.source_provenance ->
string -> unit
(* Reset the environment and record the name of the unit being
compiled (arg). Optional argument is [-for-pack] prefix. *)
@ -24,6 +25,10 @@ val current_unit_infos: unit -> unit_infos
val current_unit_name: unit -> string
(* Return the name of the unit being compiled *)
val current_build: unit -> Timings.source_provenance
(* Return the kind of build source being compiled. If it is a
file compilation it also provides the filename. *)
val make_symbol: ?unitname:string -> string option -> string
(* [make_symbol ~unitname:u None] returns the asm symbol that
corresponds to the compilation unit [u] (default: the current unit).
@ -61,6 +66,7 @@ val new_structured_constant:
string
val structured_constants:
unit -> (string * bool * Clambda.ustructured_constant) list
val clear_structured_constants: unit -> unit
val add_exported_constant: string -> unit
type structured_constants

356
asmcomp/export_info.ml Normal file
View File

@ -0,0 +1,356 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 value_string_contents =
| Contents of string
| Unknown_or_mutable
type value_string = {
contents : value_string_contents;
size : int;
}
type value_float_array_contents =
| Contents of float option array
| Unknown_or_mutable
type value_float_array = {
contents : value_float_array_contents;
size : int;
}
type descr =
| Value_block of Tag.t * approx array
| Value_mutable_block of Tag.t * int
| Value_int of int
| Value_char of char
| Value_constptr of int
| Value_float of float
| Value_float_array of value_float_array
| Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
| Value_string of value_string
| Value_closure of value_closure
| Value_set_of_closures of value_set_of_closures
and value_closure = {
closure_id : Closure_id.t;
set_of_closures : value_set_of_closures;
}
and value_set_of_closures = {
set_of_closures_id : Set_of_closures_id.t;
bound_vars : approx Var_within_closure.Map.t;
results : approx Closure_id.Map.t;
aliased_symbol : Symbol.t option;
}
and approx =
| Value_unknown
| Value_id of Export_id.t
| Value_symbol of Symbol.t
let equal_approx (a1:approx) (a2:approx) =
match a1, a2 with
| Value_unknown, Value_unknown ->
true
| Value_id id1, Value_id id2 ->
Export_id.equal id1 id2
| Value_symbol s1, Value_symbol s2 ->
Symbol.equal s1 s2
| (Value_unknown | Value_symbol _ | Value_id _),
(Value_unknown | Value_symbol _ | Value_id _) ->
false
let equal_array eq a1 a2 =
Array.length a1 = Array.length a2 &&
try
Array.iteri (fun i v1 -> if not (eq a2.(i) v1) then raise Exit) a1;
true
with Exit -> false
let equal_option eq o1 o2 =
match o1, o2 with
| None, None -> true
| Some v1, Some v2 -> eq v1 v2
| Some _, None | None, Some _ -> false
let equal_set_of_closures (s1:value_set_of_closures) (s2:value_set_of_closures) =
Set_of_closures_id.equal s1.set_of_closures_id s2.set_of_closures_id &&
Var_within_closure.Map.equal equal_approx s1.bound_vars s2.bound_vars &&
Closure_id.Map.equal equal_approx s1.results s2.results &&
equal_option Symbol.equal s1.aliased_symbol s2.aliased_symbol
let equal_descr (d1:descr) (d2:descr) : bool =
match d1, d2 with
| Value_block (t1, f1), Value_block (t2, f2) ->
Tag.equal t1 t2 && equal_array equal_approx f1 f2
| Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) ->
Tag.equal t1 t2 &&
s1 = s2
| Value_int i1, Value_int i2 ->
i1 = i2
| Value_char c1, Value_char c2 ->
c1 = c2
| Value_constptr i1, Value_constptr i2 ->
i1 = i2
| Value_float f1, Value_float f2 ->
f1 = f2
| Value_float_array s1, Value_float_array s2 ->
s1 = s2
| Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) ->
Simple_value_approx.equal_boxed_int t1 v1 t2 v2
| Value_string s1, Value_string s2 ->
s1 = s2
| Value_closure c1, Value_closure c2 ->
Closure_id.equal c1.closure_id c2.closure_id &&
equal_set_of_closures c1.set_of_closures c2.set_of_closures
| Value_set_of_closures s1, Value_set_of_closures s2 ->
equal_set_of_closures s1 s2
| ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
| Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
| Value_boxed_int _ | Value_string _ | Value_closure _
| Value_set_of_closures _ ),
( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
| Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
| Value_boxed_int _ | Value_string _ | Value_closure _
| Value_set_of_closures _ ) ->
false
type t = {
sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
closures : Flambda.function_declarations Closure_id.Map.t;
values : descr Export_id.Map.t Compilation_unit.Map.t;
globals : approx Ident.Map.t;
symbol_id : Export_id.t Symbol.Map.t;
offset_fun : int Closure_id.Map.t;
offset_fv : int Var_within_closure.Map.t;
constant_sets_of_closures : Set_of_closures_id.Set.t;
invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
}
let empty : t = {
sets_of_closures = Set_of_closures_id.Map.empty;
closures = Closure_id.Map.empty;
values = Compilation_unit.Map.empty;
globals = Ident.Map.empty;
symbol_id = Symbol.Map.empty;
offset_fun = Closure_id.Map.empty;
offset_fv = Var_within_closure.Map.empty;
constant_sets_of_closures = Set_of_closures_id.Set.empty;
invariant_params = Set_of_closures_id.Map.empty;
}
let create ~sets_of_closures ~closures ~values ~globals ~symbol_id
~offset_fun ~offset_fv ~constant_sets_of_closures
~invariant_params =
{ sets_of_closures;
closures;
values;
globals;
symbol_id;
offset_fun;
offset_fv;
constant_sets_of_closures;
invariant_params;
}
let add_clambda_info t ~offset_fun ~offset_fv ~constant_sets_of_closures =
assert (Closure_id.Map.cardinal t.offset_fun = 0);
assert (Var_within_closure.Map.cardinal t.offset_fv = 0);
assert (Set_of_closures_id.Set.cardinal t.constant_sets_of_closures = 0);
{ t with offset_fun; offset_fv; constant_sets_of_closures; }
let merge (t1 : t) (t2 : t) : t =
let eidmap_disjoint_union ?eq map1 map2 =
Compilation_unit.Map.merge (fun _id map1 map2 ->
match map1, map2 with
| None, None -> None
| None, Some map
| Some map, None -> Some map
| Some map1, Some map2 ->
Some (Export_id.Map.disjoint_union ?eq map1 map2))
map1 map2
in
let int_eq (i : int) j = i = j in
{ values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values;
globals = Ident.Map.disjoint_union t1.globals t2.globals;
sets_of_closures =
Set_of_closures_id.Map.disjoint_union t1.sets_of_closures
t2.sets_of_closures;
closures = Closure_id.Map.disjoint_union t1.closures t2.closures;
symbol_id = Symbol.Map.disjoint_union t1.symbol_id t2.symbol_id;
offset_fun = Closure_id.Map.disjoint_union
~eq:int_eq t1.offset_fun t2.offset_fun;
offset_fv = Var_within_closure.Map.disjoint_union
~eq:int_eq t1.offset_fv t2.offset_fv;
constant_sets_of_closures =
Set_of_closures_id.Set.union t1.constant_sets_of_closures
t2.constant_sets_of_closures;
invariant_params =
Set_of_closures_id.Map.disjoint_union
~eq:(Variable.Map.equal Variable.Set.equal)
t1.invariant_params t2.invariant_params;
}
let find_value eid map =
let unit_map = Compilation_unit.Map.find (Export_id.get_compilation_unit eid) map in
Export_id.Map.find eid unit_map
let find_description (t : t) eid =
find_value eid t.values
let nest_eid_map map =
let add_map eid v map =
let unit = Export_id.get_compilation_unit eid in
let m =
try Compilation_unit.Map.find unit map
with Not_found -> Export_id.Map.empty
in
Compilation_unit.Map.add unit (Export_id.Map.add eid v m) map
in
Export_id.Map.fold add_map map Compilation_unit.Map.empty
let print_approx ppf (t : t) =
let values = t.values in
let fprintf = Format.fprintf in
let printed = ref Export_id.Set.empty in
let recorded_symbol = ref Symbol.Set.empty in
let symbols_to_print = Queue.create () in
let printed_set_of_closures = ref Set_of_closures_id.Set.empty in
let rec print_approx ppf (approx : approx) =
match approx with
| Value_unknown -> fprintf ppf "?"
| Value_id id ->
if Export_id.Set.mem id !printed then
fprintf ppf "(%a: _)" Export_id.print id
else begin
try
let descr = find_value id values in
printed := Export_id.Set.add id !printed;
fprintf ppf "@[<hov 2>(%a:@ %a)@]" Export_id.print id print_descr descr
with Not_found ->
fprintf ppf "(%a: Not available)" Export_id.print id
end
| Value_symbol sym ->
if not (Symbol.Set.mem sym !recorded_symbol) then begin
recorded_symbol := Symbol.Set.add sym !recorded_symbol;
Queue.push sym symbols_to_print;
end;
Symbol.print ppf sym
and print_descr ppf (descr : descr) =
match descr with
| Value_int i -> Format.pp_print_int ppf i
| Value_char c -> fprintf ppf "%c" c
| Value_constptr i -> fprintf ppf "%ip" i
| Value_block (tag, fields) ->
fprintf ppf "[%a:%a]" Tag.print tag print_fields fields
| Value_mutable_block (tag, size) ->
fprintf ppf "[mutable %a:%i]" Tag.print tag size
| Value_closure {closure_id; set_of_closures} ->
fprintf ppf "(closure %a, %a)" Closure_id.print closure_id
print_set_of_closures set_of_closures
| Value_set_of_closures set_of_closures ->
fprintf ppf "(set_of_closures %a)" print_set_of_closures set_of_closures
| Value_string { contents; size } ->
begin match contents with
| Unknown_or_mutable -> Format.fprintf ppf "string %i" size
| Contents s ->
let s =
if size > 10
then String.sub s 0 8 ^ "..."
else s
in
Format.fprintf ppf "string %i %S" size s
end
| Value_float f -> Format.pp_print_float ppf f
| Value_float_array float_array ->
Format.fprintf ppf "float_array%s %i"
(match float_array.contents with
| Unknown_or_mutable -> ""
| Contents _ -> "_imm")
float_array.size
| Value_boxed_int (t, i) ->
let module A = Simple_value_approx in
match t with
| A.Int32 -> Format.fprintf ppf "%li" i
| A.Int64 -> Format.fprintf ppf "%Li" i
| A.Nativeint -> Format.fprintf ppf "%ni" i
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 } =
if Set_of_closures_id.Set.mem set_of_closures_id !printed_set_of_closures
then fprintf ppf "%a" Set_of_closures_id.print set_of_closures_id
else begin
printed_set_of_closures :=
Set_of_closures_id.Set.add set_of_closures_id !printed_set_of_closures;
let print_alias ppf = function
| None -> ()
| Some symbol ->
Format.fprintf ppf "@ (alias: %a)" Symbol.print symbol
in
fprintf ppf "{%a: %a%a}"
Set_of_closures_id.print set_of_closures_id
print_binding bound_vars
print_alias aliased_symbol
end
and print_binding ppf bound_vars =
Var_within_closure.Map.iter (fun clos_id approx ->
fprintf ppf "%a -> %a,@ "
Var_within_closure.print clos_id
print_approx approx)
bound_vars
in
let print_approxs id approx =
fprintf ppf "%a -> %a;@ " Ident.print id print_approx approx
in
let rec print_recorded_symbols () =
if not (Queue.is_empty symbols_to_print) then begin
let sym = Queue.pop symbols_to_print in
begin match Symbol.Map.find sym t.symbol_id with
| exception Not_found -> ()
| id ->
fprintf ppf "@[<hov 2>%a:@ %a@];@ "
Symbol.print sym
print_approx (Value_id id)
end;
print_recorded_symbols ();
end
in
fprintf ppf "@[<hov 2>Globals:@ ";
Ident.Map.iter print_approxs t.globals;
fprintf ppf "@]@ @[<hov 2>Symbols:@ ";
print_recorded_symbols ();
fprintf ppf "@]"
let print_offsets ppf (t : t) =
Format.fprintf ppf "@[<v 2>offset_fun:@ ";
Closure_id.Map.iter (fun cid off ->
Format.fprintf ppf "%a -> %i@ "
Closure_id.print cid off) t.offset_fun;
Format.fprintf ppf "@]@ @[<v 2>offset_fv:@ ";
Var_within_closure.Map.iter (fun vid off ->
Format.fprintf ppf "%a -> %i@ "
Var_within_closure.print vid off) t.offset_fv;
Format.fprintf ppf "@]@ "
let print_all ppf (t : t) =
let fprintf = Format.fprintf in
fprintf ppf "approxs@ %a@.@."
print_approx t;
fprintf ppf "functions@ %a@.@."
(Set_of_closures_id.Map.print Flambda.print_function_declarations)
t.sets_of_closures

150
asmcomp/export_info.mli Normal file
View File

@ -0,0 +1,150 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Exported information (that is to say, information written into a .cmx
file) about a compilation unit. *)
type value_string_contents =
| Contents of string
| Unknown_or_mutable
type value_string = {
contents : value_string_contents;
size : int;
}
type value_float_array_contents =
| Contents of float option array
| Unknown_or_mutable
type value_float_array = {
contents : value_float_array_contents;
size : int;
}
type descr =
| Value_block of Tag.t * approx array
| Value_mutable_block of Tag.t * int
| Value_int of int
| Value_char of char
| Value_constptr of int
| Value_float of float
| Value_float_array of value_float_array
| Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
| Value_string of value_string
| Value_closure of value_closure
| Value_set_of_closures of value_set_of_closures
and value_closure = {
closure_id : Closure_id.t;
set_of_closures : value_set_of_closures;
}
and value_set_of_closures = {
set_of_closures_id : Set_of_closures_id.t;
bound_vars : approx Var_within_closure.Map.t;
results : approx Closure_id.Map.t;
aliased_symbol : Symbol.t option;
}
(* CR-soon mshinwell: Fix the export information so we can correctly
propagate "unresolved due to..." in the manner of [Simple_value_approx].
Unfortunately this seems to be complicated by the fact that, during
[Import_approx], resolution can fail not only due to missing symbols but
also due to missing export IDs. The argument type of
[Simple_value_approx.t] may need updating to reflect this (make the
symbol optional? It's only for debugging anyway.) *)
and approx =
| Value_unknown
| Value_id of Export_id.t
| Value_symbol of Symbol.t
(** A structure that describes what a single compilation unit exports. *)
type t = private {
sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
(** Code of exported functions indexed by set of closures IDs. *)
closures : Flambda.function_declarations Closure_id.Map.t;
(** Code of exported functions indexed by closure IDs. *)
values : descr Export_id.Map.t Compilation_unit.Map.t;
(** Structure of exported values. *)
globals : approx Ident.Map.t;
(** Global variables provided by the unit: usually only the top-level
module identifier, but packs may contain more than one. *)
symbol_id : Export_id.t Symbol.Map.t;
(** Associates symbols and values. *)
offset_fun : int Closure_id.Map.t;
(** Positions of function pointers in their closures. *)
offset_fv : int Var_within_closure.Map.t;
(** Positions of value pointers in their closures. *)
constant_sets_of_closures : Set_of_closures_id.Set.t;
(* CR mshinwell for pchambart: Add comment *)
invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
(* Function parameters known to be invariant (see [Invariant_params])
indexed by set of closures ID. *)
}
(** Export information for a compilation unit that exports nothing. *)
val empty : t
(** Create a new export information structure. *)
val create
: sets_of_closures:Flambda.function_declarations Set_of_closures_id.Map.t
-> closures:Flambda.function_declarations Closure_id.Map.t
-> values:descr Export_id.Map.t Compilation_unit.Map.t
-> globals:approx Ident.Map.t
-> symbol_id:Export_id.t Symbol.Map.t
-> offset_fun:int Closure_id.Map.t
-> offset_fv:int Var_within_closure.Map.t
-> constant_sets_of_closures:Set_of_closures_id.Set.t
-> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t
-> t
(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the
current [create] function, returned by [Build_export_info]. And
another built using t and offset_informations returned by
[flambda_to_clambda] ?
mshinwell: I think we should, but after we've done the first release.
*)
(** Record information about the layout of closures and which sets of
closures are constant. These are all worked out during the
[Flambda_to_clambda] pass. *)
val add_clambda_info
: t
-> offset_fun:int Closure_id.Map.t
-> offset_fv:int Var_within_closure.Map.t
-> constant_sets_of_closures:Set_of_closures_id.Set.t
-> t
(** Union of export information. Verifies that there are no identifier
clashes. *)
val merge : t -> t -> t
(** Look up the description of an exported value given its export ID. *)
val find_description
: t
-> Export_id.t
-> descr
(** Partition a mapping from export IDs by compilation unit. *)
val nest_eid_map
: 'a Export_id.Map.t
-> 'a Export_id.Map.t Compilation_unit.Map.t
(**/**)
(* Debug printing functions. *)
val print_approx : Format.formatter -> t -> unit
val print_offsets : Format.formatter -> t -> unit
val print_all : Format.formatter -> t -> unit

143
asmcomp/export_info_for_pack.ml Normal file
View File

@ -0,0 +1,143 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
let rename_id_state = Export_id.Tbl.create 100
(* Rename export identifiers' compilation units to denote that they now
live within a pack. *)
let import_eid_for_pack units pack id =
try Export_id.Tbl.find rename_id_state id
with Not_found ->
let unit_id = Export_id.get_compilation_unit id in
let id' =
if Compilation_unit.Set.mem unit_id units
then Export_id.create ?name:(Export_id.name id) pack
else id
in
Export_id.Tbl.add rename_id_state id id';
id'
(* Similar to [import_eid_for_pack], but for symbols. *)
let import_symbol_for_pack units pack symbol =
let compilation_unit = Symbol.compilation_unit symbol in
if Compilation_unit.Set.mem compilation_unit units
then Symbol.import_for_pack ~pack symbol
else symbol
let import_approx_for_pack units pack (approx : Export_info.approx)
: Export_info.approx =
match approx with
| Value_symbol sym -> Value_symbol (import_symbol_for_pack units pack sym)
| Value_id eid -> Value_id (import_eid_for_pack units pack eid)
| Value_unknown -> Value_unknown
let import_set_of_closures 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;
bound_vars =
Var_within_closure.Map.map (import_approx_for_pack units pack)
set_of_closures.bound_vars;
results =
Closure_id.Map.map (import_approx_for_pack units pack)
set_of_closures.results;
aliased_symbol =
Misc.may_map
(import_symbol_for_pack units pack)
set_of_closures.aliased_symbol;
}
let import_descr_for_pack units pack (descr : Export_info.descr)
: Export_info.descr =
match descr with
| Value_int _
| Value_char _
| Value_constptr _
| Value_string _
| Value_float _
| Value_float_array _
| Export_info.Value_boxed_int _
| Value_mutable_block _ as desc -> desc
| Value_block (tag, fields) ->
Value_block (tag, Array.map (import_approx_for_pack units pack) fields)
| Value_closure { closure_id; set_of_closures } ->
Value_closure {
closure_id;
set_of_closures = import_set_of_closures units pack set_of_closures;
}
| Value_set_of_closures set_of_closures ->
Value_set_of_closures (import_set_of_closures units pack set_of_closures)
let 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)
| e -> e)
expr
let import_function_declarations_for_pack units pack
(function_decls : Flambda.function_declarations) =
let funs =
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
Flambda.create_function_declaration ~params:function_decl.params
~body:(import_code_for_pack units pack function_decl.body)
~stub:function_decl.stub ~dbg:function_decl.dbg
~inline:function_decl.inline
~is_a_functor:function_decl.is_a_functor)
function_decls.funs
in
Flambda.update_function_declarations function_decls ~funs
let import_eidmap_for_pack units pack f map =
Export_info.nest_eid_map
(Compilation_unit.Map.fold
(fun _ map acc -> Export_id.Map.disjoint_union map acc)
(Compilation_unit.Map.map (fun map ->
Export_id.Map.map_keys (import_eid_for_pack units pack)
(Export_id.Map.map f map))
map)
Export_id.Map.empty)
let import_for_pack ~pack_units ~pack (exp : Export_info.t) =
let import_sym = import_symbol_for_pack pack_units pack in
let import_descr = import_descr_for_pack pack_units pack in
let import_approx = import_approx_for_pack pack_units pack in
let import_eid = import_eid_for_pack pack_units pack in
let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in
let sets_of_closures =
Set_of_closures_id.Map.map
(import_function_declarations_for_pack pack_units pack)
exp.sets_of_closures
in
(* The only reachable global identifier of a pack is the pack itself. *)
let globals =
Ident.Map.filter (fun unit _ ->
Ident.same (Compilation_unit.get_persistent_ident pack) unit)
exp.globals
in
Export_info.create ~sets_of_closures
~closures:(Flambda_utils.make_closure_map' sets_of_closures)
~globals:(Ident.Map.map import_approx globals)
~offset_fun:exp.offset_fun
~offset_fv:exp.offset_fv
~values:(import_eidmap import_descr exp.values)
~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
let clear_import_state () = Export_id.Tbl.clear rename_id_state

32
asmcomp/export_info_for_pack.mli Normal file
View File

@ -0,0 +1,32 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Transformations on export information that are only used for the
building of packs. *)
(** Transform the information from [exported] to be
suitable to be reexported as the information for a pack named [pack]
containing units [pack_units].
It mainly changes symbols of units [pack_units] to refer to
[pack] instead. *)
val import_for_pack
: pack_units:Compilation_unit.Set.t
-> pack:Compilation_unit.t
-> Export_info.t
-> Export_info.t
(** Drops the state after importing several units in the same pack. *)
val clear_import_state : unit -> unit

684
asmcomp/flambda_to_clambda.ml Normal file
View File

@ -0,0 +1,684 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 for_one_or_more_units = {
fun_offset_table : int Closure_id.Map.t;
fv_offset_table : int Var_within_closure.Map.t;
closures : Flambda.function_declarations Closure_id.Map.t;
constant_sets_of_closures : Set_of_closures_id.Set.t;
}
type t = {
current_unit : for_one_or_more_units;
imported_units : for_one_or_more_units;
}
type ('a, 'b) declaration_position =
| Current_unit of 'a
| Imported_unit of 'b
| Not_declared
let get_fun_offset t closure_id =
let fun_offset_table =
if Closure_id.in_compilation_unit closure_id (Compilenv.current_unit ())
then t.current_unit.fun_offset_table
else t.imported_units.fun_offset_table
in
try Closure_id.Map.find closure_id fun_offset_table
with Not_found ->
Misc.fatal_errorf "Flambda_to_clambda: missing offset for closure %a"
Closure_id.print closure_id
let get_fv_offset t var_within_closure =
let fv_offset_table =
if Var_within_closure.in_compilation_unit var_within_closure
(Compilenv.current_unit ())
then t.current_unit.fv_offset_table
else t.imported_units.fv_offset_table
in
try Var_within_closure.Map.find var_within_closure fv_offset_table
with Not_found ->
Misc.fatal_errorf "Flambda_to_clambda: missing offset for variable %a"
Var_within_closure.print var_within_closure
let function_declaration_position t closure_id =
try
Current_unit (Closure_id.Map.find closure_id t.current_unit.closures)
with Not_found ->
try
Imported_unit (Closure_id.Map.find closure_id t.imported_units.closures)
with Not_found -> Not_declared
let is_function_constant t closure_id =
match function_declaration_position t closure_id with
| Current_unit { set_of_closures_id } ->
Set_of_closures_id.Set.mem set_of_closures_id
t.current_unit.constant_sets_of_closures
| Imported_unit { set_of_closures_id } ->
Set_of_closures_id.Set.mem set_of_closures_id
t.imported_units.constant_sets_of_closures
| Not_declared ->
Misc.fatal_errorf "Flambda_to_clambda: missing closure %a"
Closure_id.print closure_id
(* Instrumentation of closure and field accesses to try to catch compiler
bugs. *)
let check_closure ulam named : Clambda.ulambda =
if not !Clflags.clambda_checks then ulam
else
let desc =
Primitive.simple ~name:"caml_check_value_is_closure"
~arity:2 ~alloc:false
in
let str = Format.asprintf "%a" Flambda.print_named named in
let str_const =
Compilenv.new_structured_constant (Uconst_string str) ~shared:true
in
Uprim (Pccall desc,
[ulam; Clambda.Uconst (Uconst_ref (str_const, None))],
Debuginfo.none)
let check_field ulam pos named_opt : Clambda.ulambda =
if not !Clflags.clambda_checks then ulam
else
let desc =
Primitive.simple ~name:"caml_check_field_access"
~arity:3 ~alloc:false
in
let str =
match named_opt with
| None -> "<none>"
| Some named -> Format.asprintf "%a" Flambda.print_named named
in
let str_const =
Compilenv.new_structured_constant (Uconst_string str) ~shared:true
in
Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos);
Clambda.Uconst (Uconst_ref (str_const, None))],
Debuginfo.none)
module Env : sig
type t
val empty : t
val add_subst : t -> Variable.t -> Clambda.ulambda -> t
val find_subst_exn : t -> Variable.t -> Clambda.ulambda
val add_fresh_ident : t -> Variable.t -> Ident.t * t
val ident_for_var_exn : t -> Variable.t -> Ident.t
val add_fresh_mutable_ident : t -> Mutable_variable.t -> Ident.t * t
val ident_for_mutable_var_exn : t -> Mutable_variable.t -> Ident.t
val add_allocated_const : t -> Symbol.t -> Allocated_const.t -> t
val allocated_const_for_symbol : t -> Symbol.t -> Allocated_const.t option
val keep_only_symbols : t -> t
end = struct
type t =
{ subst : Clambda.ulambda Variable.Map.t;
var : Ident.t Variable.Map.t;
mutable_var : Ident.t Mutable_variable.Map.t;
toplevel : bool;
allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t;
}
let empty =
{ subst = Variable.Map.empty;
var = Variable.Map.empty;
mutable_var = Mutable_variable.Map.empty;
toplevel = false;
allocated_constant_for_symbol = Symbol.Map.empty;
}
let add_subst t id subst =
{ t with subst = Variable.Map.add id subst t.subst }
let find_subst_exn t id = Variable.Map.find id t.subst
let ident_for_var_exn t id = Variable.Map.find id t.var
let add_fresh_ident t var =
let id = Ident.create (Variable.unique_name var) in
id, { t with var = Variable.Map.add var id t.var }
let ident_for_mutable_var_exn t mut_var =
Mutable_variable.Map.find mut_var t.mutable_var
let add_fresh_mutable_ident t mut_var =
let id = Mutable_variable.unique_ident mut_var in
let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in
id, { t with mutable_var; }
let add_allocated_const t sym cons =
{ t with
allocated_constant_for_symbol =
Symbol.Map.add sym cons t.allocated_constant_for_symbol;
}
let allocated_const_for_symbol t sym =
try
Some (Symbol.Map.find sym t.allocated_constant_for_symbol)
with Not_found -> None
let keep_only_symbols t =
{ empty with
allocated_constant_for_symbol = t.allocated_constant_for_symbol;
}
end
let subst_var env var : Clambda.ulambda =
try Env.find_subst_exn env var
with Not_found ->
try Uvar (Env.ident_for_var_exn env var)
with Not_found ->
Misc.fatal_errorf "Flambda_to_clambda: unbound variable %a@."
Variable.print var
let subst_vars env vars = List.map (subst_var env) vars
let build_uoffset ulam offset : Clambda.ulambda =
if offset = 0 then ulam
else Uoffset (ulam, offset)
let to_clambda_allocated_constant (const : Allocated_const.t)
: Clambda.ustructured_constant =
match const with
| Float f -> Uconst_float f
| Int32 i -> Uconst_int32 i
| Int64 i -> Uconst_int64 i
| Nativeint i -> Uconst_nativeint i
| Immutable_string s | String s -> Uconst_string s
| Immutable_float_array a | Float_array a -> Uconst_float_array a
let to_uconst_symbol env symbol : Clambda.ustructured_constant option =
match Env.allocated_const_for_symbol env symbol with
| Some ((Float _ | Int32 _ | Int64 _ | Nativeint _) as const) ->
Some (to_clambda_allocated_constant const)
| None (* CR-soon mshinwell: Try to make this an error. *)
| Some _ -> None
let to_clambda_symbol' env sym : Clambda.uconstant =
let lbl = Linkage_name.to_string (Symbol.label sym) in
Uconst_ref (lbl, to_uconst_symbol env sym)
let to_clambda_symbol env sym : Clambda.ulambda =
Uconst (to_clambda_symbol' env sym)
let to_clambda_const env (const : Flambda.constant_defining_value_block_field)
: Clambda.uconstant =
match const with
| Symbol symbol -> to_clambda_symbol' env symbol
| Const (Int i) -> Uconst_int i
| Const (Char c) -> Uconst_int (Char.code c)
| Const (Const_pointer i) -> Uconst_ptr i
let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
match flam with
| Var var -> subst_var env var
| Let { var; defining_expr; body; _ } ->
let id, env_body = Env.add_fresh_ident env var in
Ulet (id, to_clambda_named t env var defining_expr,
to_clambda t env_body body)
| Let_mutable (mut_var, var, body) ->
let id, env_body = Env.add_fresh_mutable_ident env mut_var in
let def = subst_var env var in
Ulet (id, def, to_clambda t env_body body)
| Let_rec (defs, body) ->
let env, defs =
List.fold_right (fun (var, def) (env, defs) ->
let id, env = Env.add_fresh_ident env var in
env, (id, var, def) :: defs)
defs (env, [])
in
let defs =
List.map (fun (id, var, def) -> id, to_clambda_named t env var def) defs
in
Uletrec (defs, to_clambda t env body)
| Apply { func; args; kind = Direct direct_func; dbg = dbg } ->
to_clambda_direct_apply t func args direct_func dbg env
| Apply { func; args; kind = Indirect; dbg = dbg } ->
(* CR mshinwell for mshinwell: improve this comment *)
(* The closure parameter of the function is added by cmmgen, but
it already appears in the list of parameters of the clambda
function for generic calls. Notice that for direct calls it is
added here. *)
let callee = subst_var env func in
Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)),
subst_vars env args, dbg)
| Switch (arg, sw) ->
let aux () : Clambda.ulambda =
let const_index, const_actions =
to_clambda_switch t env sw.consts sw.numconsts sw.failaction
in
let block_index, block_actions =
to_clambda_switch t env sw.blocks sw.numblocks sw.failaction
in
Uswitch (subst_var env arg,
{ us_index_consts = const_index;
us_actions_consts = const_actions;
us_index_blocks = block_index;
us_actions_blocks = block_actions;
})
in
(* Check that the [failaction] may be duplicated. If this is not the
case, share it through a static raise / static catch. *)
(* CR-someday pchambart for pchambart: This is overly simplified. We should verify
that this does not generates too bad code. If it the case, handle some
let cases.
*)
begin match sw.failaction with
| None -> aux ()
| Some (Static_raise _) -> aux ()
| Some failaction ->
let exn = Static_exception.create () in
let sw =
{ sw with
failaction = Some (Flambda.Static_raise (exn, []));
}
in
let expr : Flambda.t =
Static_catch (exn, [], Switch (arg, sw), failaction)
in
to_clambda t env expr
end
| String_switch (arg, sw, def) ->
let arg = subst_var env arg in
let sw = List.map (fun (s, e) -> s, to_clambda t env e) sw in
let def = Misc.may_map (to_clambda t env) def in
Ustringswitch (arg, sw, def)
| Static_raise (static_exn, args) ->
Ustaticfail (Static_exception.to_int static_exn,
List.map (subst_var env) args)
| Static_catch (static_exn, vars, body, handler) ->
let env_handler, ids =
List.fold_right (fun var (env, ids) ->
let id, env = Env.add_fresh_ident env var in
env, id :: ids)
vars (env, [])
in
Ucatch (Static_exception.to_int static_exn, ids,
to_clambda t env body, to_clambda t env_handler handler)
| Try_with (body, var, handler) ->
let id, env_handler = Env.add_fresh_ident env var in
Utrywith (to_clambda t env body, id, to_clambda t env_handler handler)
| If_then_else (arg, ifso, ifnot) ->
Uifthenelse (subst_var env arg, to_clambda t env ifso,
to_clambda t env ifnot)
| While (cond, body) ->
Uwhile (to_clambda t env cond, to_clambda t env body)
| For { bound_var; from_value; to_value; direction; body } ->
let id, env_body = Env.add_fresh_ident env bound_var in
Ufor (id, subst_var env from_value, subst_var env to_value,
direction, to_clambda t env_body body)
| Assign { being_assigned; new_value } ->
let id =
try Env.ident_for_mutable_var_exn env being_assigned
with Not_found ->
Misc.fatal_errorf "Unbound mutable variable %a in [Assign]: %a"
Mutable_variable.print being_assigned
Flambda.print flam
in
Uassign (id, subst_var env new_value)
| Send { kind; meth; obj; args; dbg } ->
Usend (kind, subst_var env meth, subst_var env obj,
subst_vars env args, dbg)
| Proved_unreachable -> Uunreachable
and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
match named with
| Symbol sym -> to_clambda_symbol env sym
| Const (Const_pointer n) -> Uconst (Uconst_ptr n)
| Const (Int n) -> Uconst (Uconst_int n)
| Const (Char c) -> Uconst (Uconst_int (Char.code c))
| Allocated_const _ ->
Misc.fatal_errorf "[Allocated_const] should have been lifted to a \
[Let_symbol] construction before [Flambda_to_clambda]: %a = %a"
Variable.print var
Flambda.print_named named
| Read_mutable mut_var ->
begin try Uvar (Env.ident_for_mutable_var_exn env mut_var)
with Not_found ->
Misc.fatal_errorf "Unbound mutable variable %a in [Read_mutable]: %a"
Mutable_variable.print mut_var
Flambda.print_named named
end
| Read_symbol_field (symbol, field) ->
Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none)
| Set_of_closures set_of_closures ->
to_clambda_set_of_closures t env set_of_closures
| Project_closure { set_of_closures; closure_id } ->
(* CR mshinwell for pchambart: I don't understand how this comment
relates to this code. Can you explain? *)
(* compilation of let rec in cmmgen assumes
that a closure is not offseted (Cmmgen.expr_size) *)
check_closure (
build_uoffset
(check_closure (subst_var env set_of_closures)
(Flambda.Expr (Var set_of_closures)))
(get_fun_offset t closure_id))
named
| Move_within_set_of_closures { closure; start_from; move_to } ->
check_closure (build_uoffset
(check_closure (subst_var env closure)
(Flambda.Expr (Var closure)))
((get_fun_offset t move_to) - (get_fun_offset t start_from)))
named
| Project_var { closure; var; closure_id } ->
let ulam = subst_var env closure in
let fun_offset = get_fun_offset t closure_id in
let var_offset = get_fv_offset t var in
let pos = var_offset - fun_offset in
Uprim (Pfield pos,
[check_field (check_closure ulam (Expr (Var closure))) pos (Some named)],
Debuginfo.none)
| Prim (Pfield index, [block], dbg) ->
Uprim (Pfield index, [check_field (subst_var env block) index None], dbg)
| Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
Uprim (Psetfield (index, maybe_ptr, init), [
check_field (subst_var env block) index None;
subst_var env new_value;
], dbg)
| Prim (Popaque, args, dbg) ->
Uprim (Pidentity, subst_vars env args, dbg)
| Prim (p, args, dbg) -> Uprim (p, subst_vars env args, dbg)
| Expr expr -> to_clambda t env expr
and to_clambda_switch t env cases num_keys default =
let num_keys =
if Numbers.Int.Set.cardinal num_keys = 0 then 0
else Numbers.Int.Set.max_elt num_keys + 1
in
let index = Array.make num_keys 0 in
let store = Flambda_utils.Switch_storer.mk_store () in
begin match default with
| Some def when List.length cases < num_keys -> ignore (store.act_store def)
| _ -> ()
end;
List.iter (fun (key, lam) -> index.(key) <- store.act_store lam) cases;
let actions = Array.map (to_clambda t env) (store.act_get ()) in
match actions with
| [| |] -> [| |], [| |] (* May happen when [default] is [None]. *)
| _ -> index, actions
and to_clambda_direct_apply t func args direct_func dbg env : Clambda.ulambda =
let closed = is_function_constant t direct_func in
let label = Compilenv.function_label direct_func in
let uargs =
let uargs = subst_vars env args in
(* CR mshinwell: improve comment. Should we check [func] too? *)
(* If the function is closed, the function expression is always a
variable, so it is ok to drop it. Note that it means that
some Let can be dead. The un-anf pass should get rid of it *)
if closed then uargs else uargs @ [subst_var env func]
in
Udirect_apply (label, uargs, dbg)
(* Describe how to build a runtime closure block that corresponds to the
given Flambda set of closures.
For instance the closure for the following set of closures:
let rec fun_a x =
if x <= 0 then 0 else fun_b (x-1) v1
and fun_b x y =
if x <= 0 then 0 else v1 + v2 + y + fun_a (x-1)
will be represented in memory as:
[ closure header; fun_a;
1; infix header; fun caml_curry_2;
2; fun_b; v1; v2 ]
fun_a and fun_b will take an additional parameter 'env' to
access their closure. It will be arranged such that in the body
of each function the env parameter points to its own code
pointer. For example, in fun_b it will be shifted by 3 words.
Hence accessing v1 in the body of fun_a is accessing the
6th field of 'env' and in the body of fun_b the 1st field.
*)
and to_clambda_set_of_closures t env
(({ function_decls; free_vars } : Flambda.set_of_closures)
as set_of_closures) : Clambda.ulambda =
let all_functions = Variable.Map.bindings function_decls.funs in
let env_var = Ident.create "env" in
let to_clambda_function
(closure_id, (function_decl : Flambda.function_declaration))
: Clambda.ufunction =
let closure_id = Closure_id.wrap closure_id in
let fun_offset =
Closure_id.Map.find closure_id t.current_unit.fun_offset_table
in
let env =
(* Inside the body of the function, we cannot access variables
declared outside, so start with a suitably clean environment.
Note that we must not forget the information about which allocated
constants contain which unboxed values. *)
let env = Env.keep_only_symbols env in
(* Add the Clambda expressions for the free variables of the function
to the environment. *)
let add_env_free_variable id _ env =
let var_offset =
try
Var_within_closure.Map.find
(Var_within_closure.wrap id) t.current_unit.fv_offset_table
with Not_found ->
Misc.fatal_errorf "Clambda.to_clambda_set_of_closures: offset for \
free variable %a is unknown. Set of closures: %a"
Variable.print id
Flambda.print_set_of_closures set_of_closures
in
let pos = var_offset - fun_offset in
Env.add_subst env id
(Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none))
in
let env = Variable.Map.fold add_env_free_variable free_vars env in
(* Add the Clambda expressions for all functions defined in the current
set of closures to the environment. The various functions may be
retrieved by moving within the runtime closure, starting from the
current function's closure. *)
let add_env_function pos env (id, _) =
let offset =
Closure_id.Map.find (Closure_id.wrap id)
t.current_unit.fun_offset_table
in
let exp : Clambda.ulambda = Uoffset (Uvar env_var, offset - pos) in
Env.add_subst env id exp
in
List.fold_left (add_env_function fun_offset) env all_functions
in
let env_body, params =
List.fold_right (fun var (env, params) ->
let id, env = Env.add_fresh_ident env var in
env, id :: params)
function_decl.params (env, [])
in
{ label = Compilenv.function_label closure_id;
arity = Flambda_utils.function_arity function_decl;
params = params @ [env_var];
body = to_clambda t env_body function_decl.body;
dbg = function_decl.dbg;
}
in
let funs = List.map to_clambda_function all_functions in
let free_vars =
Variable.Map.bindings (Variable.Map.map (subst_var env) free_vars)
in
Uclosure (funs, List.map snd free_vars)
and to_clambda_closed_set_of_closures t env symbol
({ function_decls; } : Flambda.set_of_closures)
: Clambda.ustructured_constant =
let functions = Variable.Map.bindings function_decls.funs in
let to_clambda_function (id, (function_decl : Flambda.function_declaration))
: Clambda.ufunction =
(* All that we need in the environment, for translating one closure from
a closed set of closures, is the substitutions for variables bound to
the various closures in the set. Such closures will always be
referenced via symbols. *)
let env =
List.fold_left (fun env (var, _) ->
let closure_id = Closure_id.wrap var in
let symbol = Compilenv.closure_symbol closure_id in
Env.add_subst env var (to_clambda_symbol env symbol))
(Env.keep_only_symbols env)
functions
in
let env_body, params =
List.fold_right (fun var (env, params) ->
let id, env = Env.add_fresh_ident env var in
env, id :: params)
function_decl.params (env, [])
in
{ label = Compilenv.function_label (Closure_id.wrap id);
arity = Flambda_utils.function_arity function_decl;
params;
body = to_clambda t env_body function_decl.body;
dbg = function_decl.dbg;
}
in
let ufunct = List.map to_clambda_function functions in
let closure_lbl = Linkage_name.to_string (Symbol.label symbol) in
Uconst_closure (ufunct, closure_lbl, [])
let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda =
let fields =
List.mapi (fun index expr -> index, to_clambda t env expr) fields
in
let build_setfield (index, field) : Clambda.ulambda =
(* Note that this will never cause a write barrier hit, owing to
the [Initialization]. *)
Uprim (Psetfield (index, Pointer, Initialization),
[to_clambda_symbol env symbol; field],
Debuginfo.none)
in
match fields with
| [] -> Uconst (Uconst_ptr 0)
| h :: t ->
List.fold_left (fun acc (p, field) ->
Clambda.Usequence (build_setfield (p, field), acc))
(build_setfield h) t
let accumulate_structured_constants t env symbol
(c : Flambda.constant_defining_value) acc =
match c with
| Allocated_const c ->
Symbol.Map.add symbol (to_clambda_allocated_constant c) acc
| Block (tag, fields) ->
let fields = List.map (to_clambda_const env) fields in
Symbol.Map.add symbol (Clambda.Uconst_block (Tag.to_int tag, fields)) acc
| Set_of_closures set_of_closures ->
let to_clambda_set_of_closures =
to_clambda_closed_set_of_closures t env symbol set_of_closures
in
Symbol.Map.add symbol to_clambda_set_of_closures acc
| Project_closure _ -> acc
let to_clambda_program t env constants (program : Flambda.program) =
let rec loop env constants (program : Flambda.program_body)
: Clambda.ulambda * Clambda.ustructured_constant Symbol.Map.t =
match program with
| Let_symbol (symbol, alloc, program) ->
(* Useful only for unboxing. Since floats and boxed integers will
never be part of a Let_rec_symbol, handling only the Let_symbol
is sufficient. *)
let env =
match alloc with
| Allocated_const const -> Env.add_allocated_const env symbol const
| _ -> env
in
let constants =
accumulate_structured_constants t env symbol alloc constants
in
loop env constants program
| Let_rec_symbol (defs, program) ->
let constants =
List.fold_left (fun constants (symbol, alloc) ->
accumulate_structured_constants t env symbol alloc constants)
constants defs
in
loop env constants program
| Initialize_symbol (symbol, _tag, fields, program) ->
(* The tag is ignored here: It is used separately to generate the
preallocated block. Only the initialisation code is generated
here. *)
let e1 = to_clambda_initialize_symbol t env symbol fields in
let e2, constants = loop env constants program in
Usequence (e1, e2), constants
| Effect (expr, program) ->
let e1 = to_clambda t env expr in
let e2, constants = loop env constants program in
Usequence (e1, e2), constants
| End _ ->
Uconst (Uconst_ptr 0), constants
in
loop env constants program.program_body
type result = {
expr : Clambda.ulambda;
preallocated_blocks : Clambda.preallocated_block list;
structured_constants : Clambda.ustructured_constant Symbol.Map.t;
exported : Export_info.t;
}
let convert (program, exported) : result =
let current_unit =
let offsets = Closure_offsets.compute program in
{ fun_offset_table = offsets.function_offsets;
fv_offset_table = offsets.free_variable_offsets;
closures = Flambda_utils.make_closure_map program;
constant_sets_of_closures =
Flambda_utils.all_lifted_constant_sets_of_closures program;
}
in
let imported_units =
let imported = Compilenv.approx_env () in
{ fun_offset_table = imported.offset_fun;
fv_offset_table = imported.offset_fv;
closures = imported.closures;
constant_sets_of_closures = imported.constant_sets_of_closures;
}
in
let t = { current_unit; imported_units; } in
let preallocated_blocks =
List.map (fun (symbol, tag, fields) ->
{ Clambda.
symbol = Linkage_name.to_string (Symbol.label symbol);
tag = Tag.to_int tag;
size = List.length fields;
})
(Flambda_utils.initialize_symbols program)
in
let expr, structured_constants =
to_clambda_program t Env.empty Symbol.Map.empty program
in
let offset_fun, offset_fv =
Closure_offsets.compute_reexported_offsets program
~current_unit_offset_fun:current_unit.fun_offset_table
~current_unit_offset_fv:current_unit.fv_offset_table
~imported_units_offset_fun:imported_units.fun_offset_table
~imported_units_offset_fv:imported_units.fv_offset_table
in
let exported =
Export_info.add_clambda_info exported
~offset_fun
~offset_fv
~constant_sets_of_closures:current_unit.constant_sets_of_closures
in
{ expr; preallocated_blocks; structured_constants; exported; }

36
asmcomp/flambda_to_clambda.mli Normal file
View File

@ -0,0 +1,36 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
type result = {
expr : Clambda.ulambda;
preallocated_blocks : Clambda.preallocated_block list;
structured_constants : Clambda.ustructured_constant Symbol.Map.t;
exported : Export_info.t;
}
(** Convert an Flambda program, with associated proto-export information,
to Clambda.
This yields a Clambda expression together with augmented export
information and details about required statically-allocated values
(preallocated blocks, for [Initialize_symbol], and structured
constants).
It is during this process that accesses to variables within
closures are transformed to field accesses within closure values.
For direct calls, the hidden closure parameter is added. Switch
tables are also built.
*)
val convert : Flambda.program * Export_info.t -> result

27
asmcomp/i386/NOTES.md Normal file
View File

@ -0,0 +1,27 @@
# Supported platforms
Intel and AMD x86 processors in 32-bit mode.
The baseline is the 80486, also known as `i486`.
(Debian's baseline is now the Pentium 1.)
Floating-point architecture: x87.
(SSE2 not available in Debian's baseline.)
Operating systems: Linux, BSD, MacOS X, MS Windows.
Debian architecture name: `i386`
# Reference documents
* Instruction set architecture:
any Intel or AMD manual of the last 20 years.
* ELF application binary interface:
_System V Application Binary Interface,
Intel386 Architecture Processor Supplement_
* MacOS X application binary interface:
_OS X ABI Function Call Guide: IA-32 Function Calling Conventions_

171
asmcomp/import_approx.ml Normal file
View File

@ -0,0 +1,171 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
module A = Simple_value_approx
let import_set_of_closures =
let import_function_declarations (clos : Flambda.function_declarations)
: Flambda.function_declarations =
(* CR mshinwell for pchambart: Do we still need to do this rewriting?
I'm wondering if maybe we don't have to any more. *)
let sym_to_fun_var_map (clos : Flambda.function_declarations) =
Variable.Map.fold (fun fun_var _ acc ->
let closure_id = Closure_id.wrap fun_var in
let sym = Compilenv.closure_symbol closure_id in
Symbol.Map.add sym fun_var acc)
clos.funs Symbol.Map.empty
in
let sym_map = sym_to_fun_var_map clos in
let f_named (named : Flambda.named) =
match named with
| Symbol sym ->
begin try Flambda.Expr (Var (Symbol.Map.find sym sym_map)) with
| Not_found -> named
end
| named -> named
in
let funs =
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
let body =
Flambda_iterators.map_toplevel_named f_named function_decl.body
in
Flambda.create_function_declaration ~params:function_decl.params
~body ~stub:function_decl.stub ~dbg:function_decl.dbg
~inline:function_decl.inline
~is_a_functor:function_decl.is_a_functor)
clos.funs
in
Flambda.update_function_declarations clos ~funs
in
let aux 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
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
in
import_function_declarations function_declarations
in
Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux
let rec import_ex ex =
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 =
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
with
| exception Not_found ->
Misc.fatal_errorf "Set of closures ID %a not found in invariant_params \
(when importing [%a: %s])"
Set_of_closures_id.print set_of_closures_id
Export_id.print ex
what
| 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
in
match Export_info.find_description ex_info ex with
| exception Not_found -> A.value_unknown Other
| Value_int i -> A.value_int i
| Value_char c -> A.value_char c
| Value_constptr i -> A.value_constptr i
| Value_float f -> A.value_float f
| Value_float_array float_array ->
begin match float_array.contents with
| Unknown_or_mutable ->
A.value_mutable_float_array ~size:float_array.size
| Contents contents ->
A.value_immutable_float_array contents
end
| Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i
| Value_string { size; contents } ->
let contents =
match contents with
| Unknown_or_mutable -> None
| Contents contents -> Some contents
in
A.value_string size contents
| Value_mutable_block _ -> A.value_unknown Other
| Value_block (tag, fields) ->
A.value_block tag (Array.map import_approx fields)
| Value_closure { closure_id;
set_of_closures =
{ set_of_closures_id; bound_vars; aliased_symbol } } ->
let value_set_of_closures =
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
| 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
and import_approx (ap : Export_info.approx) =
match ap with
| Value_unknown -> A.value_unknown Other
| Value_id ex -> A.value_extern ex
| Value_symbol sym -> A.value_symbol sym
let import_symbol sym =
if Compilenv.is_predefined_exception sym then
A.value_unknown Other
else
let symbol_id_map =
let global = Symbol.compilation_unit sym in
(Compilenv.approx_for_global global).symbol_id
in
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
(* Note for code reviewers: Observe that [really_import] iterates until
the approximation description is fully resolved (or a necessary .cmx
file is missing). *)
let rec really_import (approx : A.descr) =
match approx with
| Value_extern ex -> really_import_ex ex
| Value_symbol sym -> really_import_symbol sym
| r -> r
and really_import_ex ex =
really_import (import_ex ex).descr
and really_import_symbol sym =
really_import (import_symbol sym).descr
let really_import_approx (approx : Simple_value_approx.t) =
A.replace_description approx (really_import approx.descr)

32
asmcomp/import_approx.mli Normal file
View File

@ -0,0 +1,32 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Create simple value approximations from the export information in
.cmx files. *)
(** Given an approximation description, load .cmx files (possibly more
than one) until the description is fully resolved. If a necessary .cmx
file cannot be found, "unresolved" will be returned. *)
val really_import : Simple_value_approx.descr -> Simple_value_approx.descr
(** Maps the description of the given approximation through [really_import]. *)
val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t
(** Read and convert the approximation of a given symbol from the
relevant .cmx file. Unlike the "really_" functions, this does not
continue to load .cmx files until the approximation is fully
resolved. *)
val import_symbol : Symbol.t -> Simple_value_approx.t

27
asmcomp/power/NOTES.md Normal file
View File

@ -0,0 +1,27 @@
# Supported platforms
IBM POWER and Freescale (nee Motorola) PowerPC processors, in three flavors:
* 32 bits, ELF ABI: Debian's `powerpc`
* 64 bits big-endian, ELF ABI v1: Debian's `powerpc`
* 64 bits little-endian, ELF ABI v2: Debian's `ppc64el`
No longer supported: AIX and MacOS X.
# Reference documents
* Instruction set architecture:
_PowerPC User Instruction Set Architecture_,
book 1 of _PowerPC Architecture Book_
(http://www.ibm.com/developerworks/systems/library/es-archguide-v2.html).
* ELF ABI 32 bits:
_System V Application Binary Interface, PowerPC Processor Supplement_
* ELF ABI 64 bits version 1:
_64-bit PowerPC ELF Application Binary Interface Supplement_
(http://refspecs.linuxfoundation.org/ELF/ppc64/PPC-elf64abi.html)
* ELF ABI 64 bits version 2:
_Power Architecture 64-bit ELF V2 ABI Specification,
OpenPOWER ABI for Linux Supplement_
(http://openpowerfoundation.org/technical/technical-resources/technical-specifications/)
* _The PowerPC Compiler Writer's Guide_, Warthman Associates, 1996.
(PDF available from various sources on the Web.)

19
asmcomp/printclambda.ml
View File

@ -31,14 +31,27 @@ let rec structured_constant ppf = function
List.iter (fun f -> fprintf ppf ",%F" f) fl;
fprintf ppf ")"
| Uconst_string s -> fprintf ppf "%S" s
| Uconst_closure(clos, sym, fv) ->
let idents ppf =
List.iter (fprintf ppf "@ %a" Ident.print)in
let one_fun ppf f =
fprintf ppf "(fun@ %s@ %d@ @[<2>%a@]@ @[<2>%a@])"
f.label f.arity idents f.params lam f.body in
let funs ppf =
List.iter (fprintf ppf "@ %a" one_fun) in
let sconsts ppf scl =
List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in
fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv
and uconstant ppf = function
| Uconst_ref (s, c) ->
| Uconst_ref (s, Some c) ->
fprintf ppf "%S=%a" s structured_constant c
| Uconst_ref (s, None) -> fprintf ppf "%S"s
| Uconst_int i -> fprintf ppf "%i" i
| Uconst_ptr i -> fprintf ppf "%ia" i
let rec lam ppf = function
and lam ppf = function
| Uvar id ->
Ident.print ppf id
| Uconst c -> uconstant ppf c
@ -157,6 +170,8 @@ let rec lam ppf = function
else if k = Lambda.Cached then "cache"
else "" in
fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
| Uunreachable ->
fprintf ppf "unreachable"
and sequence ppf ulam = match ulam with
| Usequence(l1, l2) ->

19
asmcomp/s390x/NOTES.md Normal file
View File

@ -0,0 +1,19 @@
# Supported platforms
IBM z Systems version 10 and up, in 64-bit flat addressing mode,
running Linux (Debian architecture: `s390x`).
# Reference documents
* Instruction set architecture:
_z/Architecture Principles of Operation_,
SA22-7832-07, eight edition (Feb 2009).
This is the version that corresponds to z10.
Newer versions of this manual include additional instructions
that are not in z10.
* ELF ABI:
_zSeries ELF Application Binary Interface Supplement_
(http://refspecs.linuxfoundation.org/ELF/zSeries/index.html)

21
asmcomp/sparc/NOTES.md Normal file
View File

@ -0,0 +1,21 @@
# Supported platforms
SPARC v8 and up, in 32-bit mode.
Operating systems: Solaris, Linux
(abandoned since major Linux distributions no longer support SPARC).
Status of this port: nearly abandoned
(no hardware or virtual machine available for testing).
# Reference documents
* Instruction set architecture:
_The SPARC Architecture Manual_ version 8.
* ELF application binary interface:
_System V Application Binary Interface,
SPARC Processor Supplement_

750
asmcomp/un_anf.ml Normal file
View File

@ -0,0 +1,750 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(* We say that an [Ident.t] is "linear" iff:
(a) it is used exactly once;
(b) it is never assigned to (using [Uassign]).
*)
type ident_info =
{ used : Ident.Set.t;
linear : Ident.Set.t;
assigned : Ident.Set.t;
closure_environment : Ident.Set.t;
let_bound_vars_that_can_be_moved : Ident.Set.t;
}
let ignore_uconstant (_ : Clambda.uconstant) = ()
let ignore_ulambda (_ : Clambda.ulambda) = ()
let ignore_ulambda_list (_ : Clambda.ulambda list) = ()
let ignore_function_label (_ : Clambda.function_label) = ()
let ignore_debuginfo (_ : Debuginfo.t) = ()
let ignore_int (_ : int) = ()
let ignore_ident (_ : Ident.t) = ()
let ignore_primitive (_ : Lambda.primitive) = ()
let ignore_string (_ : string) = ()
let ignore_int_array (_ : int array) = ()
let ignore_ident_list (_ : Ident.t list) = ()
let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
let ignore_meth_kind (_ : Lambda.meth_kind) = ()
(* CR-soon mshinwell: check we aren't traversing function bodies more than
once (need to analyse exactly what the calls are from Cmmgen into this
module). *)
let closure_environment_ident (ufunction:Clambda.ufunction) =
(* The argument after the arity is the environment *)
if List.length ufunction.params = ufunction.arity + 1 then
let env_var = List.nth ufunction.params ufunction.arity in
assert(Ident.name env_var = "env");
Some env_var
else
(* closed function, no environment *)
None
let make_ident_info (clam : Clambda.ulambda) : ident_info =
let t : int Ident.Tbl.t = Ident.Tbl.create 42 in
let assigned_idents = ref Ident.Set.empty in
let environment_idents = ref Ident.Set.empty in
let rec loop : Clambda.ulambda -> unit = function
(* No underscores in the pattern match, to reduce the chance of failing
to traverse some subexpression. *)
| Uvar id ->
begin match Ident.Tbl.find t id with
| n -> Ident.Tbl.replace t id (n + 1)
| exception Not_found -> Ident.Tbl.add t id 1
end
| Uconst const ->
(* The only variables that might occur in [const] are those in constant
closures---and those are all bound by such closures. It follows that
[const] cannot contain any variables that are bound in the current
scope, so we do not need to count them here. (The function bodies
of the closures will be traversed when this function is called from
[Cmmgen.transl_function].) *)
ignore_uconstant const
| Udirect_apply (label, args, dbg) ->
ignore_function_label label;
List.iter loop args;
ignore_debuginfo dbg
| Ugeneric_apply (func, args, dbg) ->
loop func;
List.iter loop args;
ignore_debuginfo dbg
| Uclosure (functions, captured_variables) ->
List.iter loop captured_variables;
List.iter (fun ({ Clambda. label; arity; params; body; dbg } as clos) ->
(match closure_environment_ident clos with
| None -> ()
| Some env_var ->
environment_idents :=
Ident.Set.add env_var !environment_idents);
ignore_function_label label;
ignore_int arity;
ignore_ident_list params;
loop body;
ignore_debuginfo dbg)
functions
| Uoffset (expr, offset) ->
loop expr;
ignore_int offset
| Ulet (ident, def, body) ->
ignore ident;
loop def;
loop body
| Uletrec (defs, body) ->
List.iter (fun (ident, def) ->
ignore_ident ident;
loop def)
defs;
loop body
| Uprim (prim, args, dbg) ->
ignore_primitive prim;
List.iter loop args;
ignore_debuginfo dbg
| Uswitch (cond, { us_index_consts; us_actions_consts;
us_index_blocks; us_actions_blocks }) ->
loop cond;
ignore_int_array us_index_consts;
Array.iter loop us_actions_consts;
ignore_int_array us_index_blocks;
Array.iter loop us_actions_blocks
| Ustringswitch (cond, branches, default) ->
loop cond;
List.iter (fun (str, branch) ->
ignore_string str;
loop branch)
branches;
Misc.may loop default
| Ustaticfail (static_exn, args) ->
ignore_int static_exn;
List.iter loop args
| Ucatch (static_exn, idents, body, handler) ->
ignore_int static_exn;
ignore_ident_list idents;
loop body;
loop handler
| Utrywith (body, ident, handler) ->
loop body;
ignore_ident ident;
loop handler
| Uifthenelse (cond, ifso, ifnot) ->
loop cond;
loop ifso;
loop ifnot
| Usequence (e1, e2) ->
loop e1;
loop e2
| Uwhile (cond, body) ->
loop cond;
loop body
| Ufor (ident, low, high, direction_flag, body) ->
ignore_ident ident;
loop low;
loop high;
ignore_direction_flag direction_flag;
loop body
| Uassign (ident, expr) ->
assigned_idents := Ident.Set.add ident !assigned_idents;
loop expr
| Usend (meth_kind, e1, e2, args, dbg) ->
ignore_meth_kind meth_kind;
loop e1;
loop e2;
List.iter loop args;
ignore_debuginfo dbg
| Uunreachable ->
()
in
loop clam;
let linear =
Ident.Tbl.fold (fun id n acc ->
assert (n >= 1);
if n = 1 && not (Ident.Set.mem id !assigned_idents)
then Ident.Set.add id acc
else acc)
t Ident.Set.empty
in
let assigned = !assigned_idents in
let used =
(* This doesn't work transitively and thus is somewhat restricted. In
particular, it does not allow us to get rid of useless chains of [let]s.
However it should be sufficient to remove the majority of unnecessary
[let] bindings that might hinder [Cmmgen]. *)
Ident.Tbl.fold (fun id _n acc -> Ident.Set.add id acc)
t assigned
in
{ used; linear; assigned; closure_environment = !environment_idents;
let_bound_vars_that_can_be_moved = Ident.Set.empty;
}
(* When sequences of [let]-bindings match the evaluation order in a subsequent
primitive or function application whose arguments are linearly-used
non-assigned variables bound by such lets (possibly interspersed with other
variables that are known to be constant), and it is known that there were no
intervening side-effects during the evaluation of the [let]-bindings,
permit substitution of the variables for their defining expressions. *)
let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) =
let obviously_constant = ref Ident.Set.empty in
let can_move = ref Ident.Set.empty in
let let_stack = ref [] in
let examine_argument_list args =
let rec loop let_bound_vars (args : Clambda.ulambda list) =
match let_bound_vars, args with
| _, [] ->
(* We've matched all arguments and will not substitute (in the
current application being considered) any of the remaining
[let_bound_vars]. As such they may stay on the stack. *)
let_bound_vars
| [], _ ->
(* There are no more [let]-bindings to consider, so the stack
is left empty. *)
[]
| let_bound_vars, (Uvar arg)::args
when Ident.Set.mem arg !obviously_constant ->
loop let_bound_vars args
| let_bound_var::let_bound_vars, (Uvar arg)::args
when Ident.same let_bound_var arg
&& not (Ident.Set.mem arg ident_info.assigned) ->
assert (Ident.Set.mem arg ident_info.used);
assert (Ident.Set.mem arg ident_info.linear);
can_move := Ident.Set.add arg !can_move;
loop let_bound_vars args
| _::_, _::_ ->
(* The [let] sequence has ceased to match the evaluation order
or we have encountered some complicated argument. In this case
we empty the stack to ensure that we do not end up moving an
outer [let] across a side effect. *)
[]
in
(* Start at the most recent let binding and the leftmost argument
(the last argument to be evaluated). *)
let_stack := loop !let_stack args
in
let rec loop : Clambda.ulambda -> unit = function
| Uvar ident ->
if Ident.Set.mem ident ident_info.assigned then begin
let_stack := []
end
| Uconst const ->
ignore_uconstant const
| Udirect_apply (label, args, dbg) ->
ignore_function_label label;
examine_argument_list args;
(* We don't currently traverse [args]; they should all be variables
anyway. If this is added in the future, take care to traverse [args]
following the evaluation order. *)
ignore_debuginfo dbg
| Ugeneric_apply (func, args, dbg) ->
examine_argument_list (args @ [func]);
ignore_debuginfo dbg
| Uclosure (functions, captured_variables) ->
ignore_ulambda_list captured_variables;
(* Start a new let stack for speed. *)
List.iter (fun { Clambda. label; arity; params; body; dbg; } ->
ignore_function_label label;
ignore_int arity;
ignore_ident_list params;
let_stack := [];
loop body;
let_stack := [];
ignore_debuginfo dbg)
functions
| Uoffset (expr, offset) ->
(* [expr] should usually be a variable. *)
examine_argument_list [expr];
ignore_int offset
| Ulet (ident, def, body) ->
begin match def with
| Uconst _ ->
(* The defining expression is obviously constant, so we don't
have to put this [let] on the stack, and we don't have to
traverse the defining expression either. *)
obviously_constant := Ident.Set.add ident !obviously_constant;
loop body
| _ ->
loop def;
if Ident.Set.mem ident ident_info.linear then begin
let_stack := ident::!let_stack
end else begin
(* If we encounter a non-linear [let]-binding then we must clear
the let stack, since we cannot now move any previous binding
across the non-linear one. *)
let_stack := []
end;
loop body
end
| Uletrec (defs, body) ->
(* Evaluation order for [defs] is not defined, and this case
probably isn't important for [Cmmgen] anyway. *)
let_stack := [];
List.iter (fun (ident, def) ->
ignore_ident ident;
loop def;
let_stack := [])
defs;
loop body
| Uprim (prim, args, dbg) ->
ignore_primitive prim;
examine_argument_list args;
ignore_debuginfo dbg
| Uswitch (cond, { us_index_consts; us_actions_consts;
us_index_blocks; us_actions_blocks }) ->
examine_argument_list [cond];
ignore_int_array us_index_consts;
Array.iter (fun action ->
let_stack := [];
loop action)
us_actions_consts;
ignore_int_array us_index_blocks;
Array.iter (fun action ->
let_stack := [];
loop action)
us_actions_blocks;
let_stack := []
| Ustringswitch (cond, branches, default) ->
examine_argument_list [cond];
List.iter (fun (str, branch) ->
ignore_string str;
let_stack := [];
loop branch)
branches;
let_stack := [];
Misc.may loop default;
let_stack := []
| Ustaticfail (static_exn, args) ->
ignore_int static_exn;
ignore_ulambda_list args;
let_stack := []
| Ucatch (static_exn, idents, body, handler) ->
ignore_int static_exn;
ignore_ident_list idents;
let_stack := [];
loop body;
let_stack := [];
loop handler;
let_stack := []
| Utrywith (body, ident, handler) ->
let_stack := [];
loop body;
let_stack := [];
ignore_ident ident;
loop handler;
let_stack := []
| Uifthenelse (cond, ifso, ifnot) ->
examine_argument_list [cond];
let_stack := [];
loop ifso;
let_stack := [];
loop ifnot;
let_stack := []
| Usequence (e1, e2) ->
loop e1;
let_stack := [];
loop e2;
let_stack := []
| Uwhile (cond, body) ->
let_stack := [];
loop cond;
let_stack := [];
loop body;
let_stack := []
| Ufor (ident, low, high, direction_flag, body) ->
ignore_ident ident;
(* Cmmgen generates code that evaluates low before high,
but we don't do anything here at the moment anyway. *)
ignore_ulambda low;
ignore_ulambda high;
ignore_direction_flag direction_flag;
let_stack := [];
loop body;
let_stack := []
| Uassign (ident, expr) ->
ignore_ident ident;
ignore_ulambda expr;
let_stack := []
| Usend (meth_kind, e1, e2, args, dbg) ->
ignore_meth_kind meth_kind;
ignore_ulambda e1;
ignore_ulambda e2;
ignore_ulambda_list args;
let_stack := [];
ignore_debuginfo dbg
| Uunreachable ->
let_stack := []
in
loop clam;
!can_move
(* Substitution of an expression for a let-moveable variable can cause the
surrounding expression to become fixed. To avoid confusion, do the
let-moveable substitutions first. *)
let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda)
: Clambda.ulambda =
match clam with
| Uvar id ->
if not (Ident.Set.mem id is_let_moveable) then
clam
else
begin match Ident.Map.find id env with
| clam -> clam
| exception Not_found ->
Misc.fatal_errorf "substitute_let_moveable: Unbound identifier %a"
Ident.print id
end
| Uconst _ -> clam
| Udirect_apply (label, args, dbg) ->
let args = substitute_let_moveable_list is_let_moveable env args in
Udirect_apply (label, args, dbg)
| Ugeneric_apply (func, args, dbg) ->
let func = substitute_let_moveable is_let_moveable env func in
let args = substitute_let_moveable_list is_let_moveable env args in
Ugeneric_apply (func, args, dbg)
| Uclosure (functions, variables_bound_by_the_closure) ->
let functions =
List.map (fun (ufunction : Clambda.ufunction) ->
{ ufunction with
body = substitute_let_moveable is_let_moveable env ufunction.body;
})
functions
in
let variables_bound_by_the_closure =
substitute_let_moveable_list is_let_moveable env variables_bound_by_the_closure
in
Uclosure (functions, variables_bound_by_the_closure)
| Uoffset (clam, n) ->
let clam = substitute_let_moveable is_let_moveable env clam in
Uoffset (clam, n)
| Ulet (id, def, body) ->
let def = substitute_let_moveable is_let_moveable env def in
if Ident.Set.mem id is_let_moveable then
let env = Ident.Map.add id def env in
substitute_let_moveable is_let_moveable env body
else
Ulet (id, def, substitute_let_moveable is_let_moveable env body)
| Uletrec (defs, body) ->
let defs =
List.map (fun (id, def) ->
id, substitute_let_moveable is_let_moveable env def)
defs
in
let body = substitute_let_moveable is_let_moveable env body in
Uletrec (defs, body)
| Uprim (prim, args, dbg) ->
let args = substitute_let_moveable_list is_let_moveable env args in
Uprim (prim, args, dbg)
| Uswitch (cond, sw) ->
let cond = substitute_let_moveable is_let_moveable env cond in
let sw =
{ sw with
us_actions_consts = substitute_let_moveable_array is_let_moveable env sw.us_actions_consts;
us_actions_blocks = substitute_let_moveable_array is_let_moveable env sw.us_actions_blocks;
}
in
Uswitch (cond, sw)
| Ustringswitch (cond, branches, default) ->
let cond = substitute_let_moveable is_let_moveable env cond in
let branches =
List.map (fun (s, branch) -> s, substitute_let_moveable is_let_moveable env branch)
branches
in
let default = Misc.may_map (substitute_let_moveable is_let_moveable env) default in
Ustringswitch (cond, branches, default)
| Ustaticfail (n, args) ->
let args = substitute_let_moveable_list is_let_moveable env args in
Ustaticfail (n, args)
| Ucatch (n, ids, body, handler) ->
let body = substitute_let_moveable is_let_moveable env body in
let handler = substitute_let_moveable is_let_moveable env handler in
Ucatch (n, ids, body, handler)
| Utrywith (body, id, handler) ->
let body = substitute_let_moveable is_let_moveable env body in
let handler = substitute_let_moveable is_let_moveable env handler in
Utrywith (body, id, handler)
| Uifthenelse (cond, ifso, ifnot) ->
let cond = substitute_let_moveable is_let_moveable env cond in
let ifso = substitute_let_moveable is_let_moveable env ifso in
let ifnot = substitute_let_moveable is_let_moveable env ifnot in
Uifthenelse (cond, ifso, ifnot)
| Usequence (e1, e2) ->
let e1 = substitute_let_moveable is_let_moveable env e1 in
let e2 = substitute_let_moveable is_let_moveable env e2 in
Usequence (e1, e2)
| Uwhile (cond, body) ->
let cond = substitute_let_moveable is_let_moveable env cond in
let body = substitute_let_moveable is_let_moveable env body in
Uwhile (cond, body)
| Ufor (id, low, high, direction, body) ->
let low = substitute_let_moveable is_let_moveable env low in
let high = substitute_let_moveable is_let_moveable env high in
let body = substitute_let_moveable is_let_moveable env body in
Ufor (id, low, high, direction, body)
| Uassign (id, expr) ->
let expr = substitute_let_moveable is_let_moveable env expr in
Uassign (id, expr)
| Usend (kind, e1, e2, args, dbg) ->
let e1 = substitute_let_moveable is_let_moveable env e1 in
let e2 = substitute_let_moveable is_let_moveable env e2 in
let args = substitute_let_moveable_list is_let_moveable env args in
Usend (kind, e1, e2, args, dbg)
| Uunreachable ->
Uunreachable
and substitute_let_moveable_list is_let_moveable env clams =
List.map (substitute_let_moveable is_let_moveable env) clams
and substitute_let_moveable_array is_let_moveable env clams =
Array.map (substitute_let_moveable is_let_moveable env) clams
(* We say that an expression is "moveable" iff it has neither effects nor
coeffects. (See semantics_of_primitives.mli.)
*)
type moveable = Fixed | Moveable | Moveable_not_into_loops
let both_moveable a b =
match a, b with
| Moveable, Moveable -> Moveable
| Moveable_not_into_loops, Moveable
| Moveable, Moveable_not_into_loops
| Moveable_not_into_loops, Moveable_not_into_loops -> Moveable_not_into_loops
| Moveable, Fixed
| Moveable_not_into_loops, Fixed
| Fixed, Moveable_not_into_loops
| Fixed, Moveable
| Fixed, Fixed -> Fixed
let primitive_moveable (prim : Lambda.primitive)
(args : Clambda.ulambda list)
(ident_info : ident_info) =
match prim, args with
| Pfield _, [Uconst (Uconst_ref (_, _))] ->
(* CR mshinwell: Actually, maybe this shouldn't be needed; these should
have been simplified to [Read_symbol_field], which doesn't yield a
Clambda let. This might be fixed when Inline_and_simplify can
turn Pfield into Read_symbol_field. *)
(* Allow field access of symbols to be moveable. (The comment in
flambda.mli on [Read_symbol_field] may be helpful to the reader.) *)
Moveable
| Pfield _, [Uvar id] when Ident.Set.mem id ident_info.closure_environment ->
(* accesses to the function environment is coeffect free: this block
is never mutated *)
Moveable
| _ ->
match Semantics_of_primitives.for_primitive prim with
| No_effects, No_coeffects -> Moveable
| No_effects, Has_coeffects
| Only_generative_effects, No_coeffects
| Only_generative_effects, Has_coeffects
| Arbitrary_effects, No_coeffects
| Arbitrary_effects, Has_coeffects -> Fixed
type moveable_for_env = 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
| Moveable -> Some (Moveable, def)
| Moveable_not_into_loops -> None)
(** Eliminate, through substitution, [let]-bindings of linear variables with
moveable defining expressions. *)
let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
: Clambda.ulambda * moveable =
match clam with
| Uvar id ->
begin match Ident.Map.find id env with
| 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
Fixed
else
Moveable
in
clam, moveable
end
| Uconst _ ->
(* Constant closures are rewritten separately. *)
clam, Moveable
| Udirect_apply (label, args, dbg) ->
let args = un_anf_list ident_info env args in
Udirect_apply (label, args, dbg), Fixed
| Ugeneric_apply (func, args, dbg) ->
let func = un_anf ident_info env func in
let args = un_anf_list ident_info env args in
Ugeneric_apply (func, args, dbg), Fixed
| Uclosure (functions, variables_bound_by_the_closure) ->
let functions =
List.map (fun (ufunction : Clambda.ufunction) ->
{ ufunction with
body = un_anf ident_info (going_into_loop 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
in
Uclosure (functions, variables_bound_by_the_closure),
both_moveable moveable Moveable_not_into_loops
| Uoffset (clam, n) ->
let clam, moveable = un_anf_and_moveable ident_info env clam in
Uoffset (clam, n), moveable
| Ulet (id, def, Uvar id') when Ident.same id id' ->
un_anf_and_moveable ident_info env def
| Ulet (id, def, body) ->
let def, def_moveable = un_anf_and_moveable ident_info env def in
let is_linear = Ident.Set.mem id ident_info.linear in
let is_used = Ident.Set.mem id ident_info.used in
begin match def_moveable, is_linear, is_used with
| (Moveable | Moveable_not_into_loops), _, false ->
(* A moveable expression that is never used may be eliminated. *)
un_anf_and_moveable ident_info env body
| Moveable, true, true ->
(* A moveable expression bound to a linear [Ident.t] may replace the
single occurrence of the identifier. *)
let env =
let def_moveable : moveable_for_env =
match def_moveable with
| Moveable -> Moveable
| Moveable_not_into_loops -> Moveable_not_into_loops
| Fixed -> assert false
in
Ident.Map.add id (def_moveable, def) env
in
un_anf_and_moveable ident_info env body
| Moveable_not_into_loops, true, true
(* We can't delete the [let] binding in this case because we don't
know whether the variable was substituted for its definition
(in the case of its linear use not being inside a loop) or not.
We could extend the code to cope with this case. *)
| (Moveable | Moveable_not_into_loops), false, true
(* Moveable but not used linearly. *)
| Fixed, _, _ ->
let body, body_moveable = un_anf_and_moveable ident_info env body in
Ulet (id, def, body), both_moveable def_moveable body_moveable
end
| Uletrec (defs, body) ->
let defs =
List.map (fun (id, def) -> id, un_anf ident_info env def) defs
in
let body = un_anf ident_info env body in
Uletrec (defs, body), Fixed
| Uprim (prim, args, dbg) ->
let args, args_moveable = un_anf_list_and_moveable ident_info env args in
let moveable =
both_moveable args_moveable (primitive_moveable prim args ident_info)
in
Uprim (prim, args, dbg), moveable
| Uswitch (cond, sw) ->
let cond = un_anf ident_info env cond in
let sw =
{ sw with
us_actions_consts = un_anf_array ident_info env sw.us_actions_consts;
us_actions_blocks = un_anf_array ident_info env sw.us_actions_blocks;
}
in
Uswitch (cond, sw), Fixed
| Ustringswitch (cond, branches, default) ->
let cond = un_anf ident_info env cond in
let branches =
List.map (fun (s, branch) -> s, un_anf ident_info env branch)
branches
in
let default = Misc.may_map (un_anf ident_info env) default in
Ustringswitch (cond, branches, default), Fixed
| Ustaticfail (n, args) ->
let args = un_anf_list ident_info env args in
Ustaticfail (n, args), Fixed
| Ucatch (n, ids, body, handler) ->
let body = un_anf ident_info env body in
let handler = un_anf ident_info env handler in
Ucatch (n, ids, body, handler), Fixed
| Utrywith (body, id, handler) ->
let body = un_anf ident_info env body in
let handler = un_anf ident_info env handler in
Utrywith (body, id, handler), Fixed
| Uifthenelse (cond, ifso, ifnot) ->
let cond, cond_moveable = un_anf_and_moveable ident_info env cond in
let ifso, ifso_moveable = un_anf_and_moveable ident_info env ifso in
let ifnot, ifnot_moveable = un_anf_and_moveable ident_info env ifnot in
let moveable =
both_moveable cond_moveable
(both_moveable ifso_moveable ifnot_moveable)
in
Uifthenelse (cond, ifso, ifnot), moveable
| Usequence (e1, e2) ->
let e1 = un_anf ident_info env e1 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
Ufor (id, low, high, direction, body), Fixed
| Uassign (id, expr) ->
let expr = un_anf ident_info env expr in
Uassign (id, expr), Fixed
| Usend (kind, e1, e2, args, dbg) ->
let e1 = un_anf ident_info env e1 in
let e2 = un_anf ident_info env e2 in
let args = un_anf_list ident_info env args in
Usend (kind, e1, e2, args, dbg), Fixed
| Uunreachable ->
Uunreachable, Fixed
and un_anf ident_info env clam : Clambda.ulambda =
let clam, _moveable = un_anf_and_moveable ident_info env clam in
clam
and un_anf_list_and_moveable ident_info env clams
: Clambda.ulambda list * moveable =
List.fold_right (fun clam (l, acc_moveable) ->
let clam, moveable = un_anf_and_moveable ident_info env clam in
clam :: l, both_moveable moveable acc_moveable)
clams ([], (Moveable : moveable))
and un_anf_list ident_info env clams : Clambda.ulambda list =
let clams, _moveable = un_anf_list_and_moveable ident_info env clams in
clams
and un_anf_array ident_info env clams : Clambda.ulambda array =
Array.map (un_anf ident_info env) clams
let apply clam ~what =
if not Config.flambda then clam
else begin
let ident_info = make_ident_info clam in
let let_bound_vars_that_can_be_moved =
let_bound_vars_that_can_be_moved ident_info clam
in
let clam =
substitute_let_moveable let_bound_vars_that_can_be_moved
Ident.Map.empty clam
in
let ident_info = make_ident_info clam in
let clam = un_anf ident_info Ident.Map.empty clam in
if !Clflags.dump_clambda then begin
Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam
end;
clam
end

22
asmcomp/un_anf.mli Normal file
View File

@ -0,0 +1,22 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Expand ANF-like constructs so that pattern matches in [Cmmgen] will
work correctly. *)
val apply
: Clambda.ulambda
-> what:string
-> Clambda.ulambda

2478
asmrun/.depend
View File

File diff suppressed because it is too large Load Diff

76
asmrun/Makefile
View File

@ -18,12 +18,13 @@ FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \
-DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) $(IFLEXDIR)
CFLAGS=$(FLAGS) $(NATIVECCCOMPOPTS)
DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS)
IFLAGS=$(FLAGS) -DCAML_INSTR
PFLAGS=$(FLAGS) -pg -DPROFILING $(NATIVECCPROFOPTS) $(NATIVECCCOMPOPTS)
PICFLAGS=$(FLAGS) $(SHAREDCCCOMPOPTS) $(NATIVECCCOMPOPTS)
COBJS=startup_aux.o startup.o \
main.o fail.o roots.o globroots.o signals.o signals_asm.o \
misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.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 \
@ -34,11 +35,16 @@ ASMOBJS=$(ARCH).o
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)
all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING) all-$(SHARED)
ifeq "$(RUNTIMEI)" "true"
all: libasmruni.a
endif
libasmrun.a: $(OBJS)
rm -f libasmrun.a
$(ARCMD) rc libasmrun.a $(OBJS)
@ -55,6 +61,11 @@ libasmrund.a: $(DOBJS)
$(ARCMD) rc libasmrund.a $(DOBJS)
$(RANLIB) libasmrund.a
libasmruni.a: $(IOBJS)
rm -f $@
$(ARCMD) rc $@ $^
$(RANLIB) $@
all-noprof:
all-prof: libasmrunp.a
@ -78,40 +89,39 @@ libasmrun_shared.so: $(PICOBJS)
INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
install: install-default install-$(RUNTIMED) install-$(PROFILING) \
install-$(SHARED)
install-default:
install::
cp libasmrun.a $(INSTALL_LIBDIR)/libasmrun.a
cd $(INSTALL_LIBDIR); $(RANLIB) libasmrun.a
.PHONY: install-default
install-noruntimed:
.PHONY: install-noruntimed
install-runtimed:
ifeq "$(RUNTIMED)" "runtimed"
install::
cp libasmrund.a $(INSTALL_LIBDIR)/libasmrund.a
cd $(INSTALL_LIBDIR); $(RANLIB) libasmrund.a
.PHONY: install-runtimed
endif
install-noprof:
rm -f $(INSTALL_LIBDIR)/libasmrunp.a
ln -s libasmrun.a $(INSTALL_LIBDIR)/libasmrunp.a
.PHONY: install-noprof
ifeq "$(RUNTIMEI)" "true"
install::
cp libasmruni.a $(INSTALL_LIBDIR)/libasmruni.a
cd $(INSTALL_LIBDIR); $(RANLIB) libasmruni.a
endif
install-prof:
ifeq "$(PROFILING)" "prof"
install::
cp libasmrunp.a $(INSTALL_LIBDIR)/libasmrunp.a
cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a
.PHONY: install-prof
else
install::
rm -f $(INSTALL_LIBDIR)/libasmrunp.a
ln -s libasmrun.a $(INSTALL_LIBDIR)/libasmrunp.a
endif
install-noshared:
.PHONY: install-noshared
install-shared:
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
.PHONY: install-prof
endif
main.c: ../byterun/main.c
ln -s ../byterun/main.c main.c
@ -197,6 +207,18 @@ LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
clean::
rm -f $(LINKEDFILES)
%.d.o: %.c
$(CC) -c $(DFLAGS) -o $@ $<
%.i.o : %.c
$(CC) -c $(IFLAGS) -o $@ $<
%.p.o: %.c
$(CC) -c $(PFLAGS) -o $@ $<
%.pic.o: %.c
$(CC) -c $(PICFLAGS) -o $@ $<
%.o: %.S
$(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $@ $< || \
{ echo "If your assembler produced syntax errors, it is probably";\
@ -210,15 +232,6 @@ clean::
%.pic.o: %.S
$(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(SHAREDCCCOMPOPTS) -o $@ $<
%.d.o: %.c
$(CC) -c $(DFLAGS) -o $@ $<
%.p.o: %.c
$(CC) -c $(PFLAGS) -o $@ $<
%.pic.o: %.c
$(CC) -c $(PICFLAGS) -o $@ $<
%.o: %.s
$(ASPP) -DSYS_$(SYSTEM) -o $@ $<
@ -233,7 +246,8 @@ clean::
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) *.c | sed -e 's/\.o/.p.o/' >> .depend
$(CC) -MM $(FLAGS) -DCAML_INSTR *.c | sed -e 's/\.o/.i.o/' >> .depend
include .depend

3
asmrun/arm.S
View File

@ -518,3 +518,6 @@ caml_system__frametable:
.align 2
.type caml_system__frametable, %object
.size caml_system__frametable, .-caml_system__frametable
/* Mark stack as non-executable */
.section .note.GNU-stack,"",%progbits

3
asmrun/arm64.S
View File

@ -553,3 +553,6 @@ caml_system__frametable:
.align 3
.type caml_system__frametable, %object
.size caml_system__frametable, .-caml_system__frametable
/* Mark stack as non-executable */
.section .note.GNU-stack,"",%progbits

84
asmrun/clambda_checks.c Normal file
View File

@ -0,0 +1,84 @@
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Pierre Chambart, OCamlPro */
/* Mark Shinwell, Jane Street Europe */
/* */
/* Copyright 2015 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/* Runtime checks to try to catch errors in code generation.
See flambda_to_clambda.ml for more information. */
#include <assert.h>
#include <stdio.h>
#include <caml/mlvalues.h>
value caml_check_value_is_closure(value v, value v_descr)
{
const char* descr = String_val(v_descr);
value orig_v = v;
if (v == (value) 0) {
fprintf(stderr, "NULL is not a closure: %s\n",
descr);
abort();
}
if (!Is_block(v)) {
fprintf(stderr,
"Expecting a closure, got a non-boxed value %p: %s\n",
(void*) v, descr);
abort();
}
if (!(Tag_val(v) == Closure_tag || Tag_val(v) == Infix_tag)) {
fprintf(stderr,
"Expecting a closure, got a boxed value with tag %i: %s\n",
Tag_val(v), descr);
abort();
}
if (Tag_val(v) == Infix_tag) {
v -= Infix_offset_val(v);
assert(Tag_val(v) == Closure_tag);
}
assert(Wosize_val(v) >= 2);
return orig_v;
}
value caml_check_field_access(value v, value pos, value v_descr)
{
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",
(unsigned long long) Long_val(pos), descr);
abort();
}
if (!Is_block(v)) {
fprintf(stderr,
"Access to field %lld of non-boxed value %p is illegal: %s\n",
(unsigned long long) Long_val(pos), (void*) v, descr);
abort();
}
if (Tag_val(v) == Infix_tag) {
uintnat offset = Infix_offset_val(v);
v -= offset;
pos += offset / sizeof(value);
}
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",
(unsigned long long) Long_val(pos), (void*) v,
(unsigned long long) Wosize_val(v),
descr);
abort();
}
return orig_v;
}

3
asmrun/power.S
View File

@ -690,3 +690,6 @@ TOCENTRY(caml_young_limit)
TOCENTRY(caml_young_ptr)
#endif
/* Mark stack as non-executable */
.section .note.GNU-stack,"",%progbits

77
asmrun/roots.c
View File

@ -335,27 +335,78 @@ void caml_oldify_local_roots (void)
if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one);
}
/* Call [darken] on all roots */
uintnat caml_incremental_roots_count = 0;
void caml_darken_all_roots (void)
/* Call [caml_darken] on all roots, incrementally:
[caml_darken_all_roots_start] does the non-incremental part and
sets things up for [caml_darken_all_roots_slice].
*/
void caml_darken_all_roots_start (void)
{
caml_do_roots (caml_darken);
caml_do_roots (caml_darken, 0);
}
void caml_do_roots (scanning_action f)
/* Call [caml_darken] on at most [work] global roots. Return the
amount of work not done, if any. If this is strictly positive,
the darkening is done.
*/
intnat caml_darken_all_roots_slice (intnat work)
{
static int i, j;
static value *glob;
static int do_resume = 0;
static mlsize_t roots_count = 0;
intnat remaining_work = work;
CAML_INSTR_SETUP (tmr, "");
/* If the loop was started in a previous call, resume it. */
if (do_resume) goto resume;
/* This is the same loop as in [caml_do_roots], but we make it
suspend itself when [work] reaches 0. */
for (i = 0; caml_globals[i] != 0; i++) {
for(glob = caml_globals[i]; *glob != 0; glob++) {
for (j = 0; j < Wosize_val(*glob); j++){
caml_darken (Field (*glob, j), &Field (*glob, j));
-- remaining_work;
if (remaining_work == 0){
roots_count += work;
do_resume = 1;
goto suspend;
}
resume: ;
}
}
}
/* The loop finished normally, so all roots are now darkened. */
caml_incremental_roots_count = roots_count + work - remaining_work;
/* Prepare for the next run. */
do_resume = 0;
roots_count = 0;
suspend:
/* Do this in both cases. */
CAML_INSTR_TIME (tmr, "major/mark/global_roots_slice");
return remaining_work;
}
void caml_do_roots (scanning_action f, int do_globals)
{
int i, j;
value * glob;
link *lnk;
CAML_INSTR_SETUP (tmr, "major_roots");
/* The global roots */
for (i = 0; caml_globals[i] != 0; i++) {
for(glob = caml_globals[i]; *glob != 0; glob++) {
for (j = 0; j < Wosize_val(*glob); j++)
f (Field (*glob, j), &Field (*glob, j));
if (do_globals){
/* The global roots */
for (i = 0; caml_globals[i] != 0; i++) {
for(glob = caml_globals[i]; *glob != 0; glob++) {
for (j = 0; j < Wosize_val(*glob); j++)
f (Field (*glob, j), &Field (*glob, j));
}
}
}
/* Dynamic global roots */
iter_list(caml_dyn_globals, lnk) {
for(glob = (value *) lnk->data; *glob != 0; glob++) {
@ -364,16 +415,20 @@ void caml_do_roots (scanning_action f)
}
}
}
CAML_INSTR_TIME (tmr, "major_roots/dynamic_global");
/* The stack and local roots */
caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address,
caml_gc_regs, caml_local_roots);
CAML_INSTR_TIME (tmr, "major_roots/local");
/* Global C roots */
caml_scan_global_roots(f);
CAML_INSTR_TIME (tmr, "major_roots/C");
/* Finalised values */
caml_final_do_strong_roots (f);
CAML_INSTR_TIME (tmr, "major_roots/finalised");
/* Hook */
if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);
CAML_INSTR_TIME (tmr, "major_roots/hook");
}
void caml_do_local_roots(scanning_action f, char * bottom_of_stack,

3
asmrun/s390x.S
View File

@ -351,3 +351,6 @@ caml_system__frametable:
.short -1 /* negative size count => use callback link */
.short 0 /* no roots here */
.align 8
/* Mark stack as non-executable */
.section .note.GNU-stack,"",%progbits

8
asmrun/signals_asm.c
View File

@ -67,9 +67,11 @@ extern char caml_system__code_begin, caml_system__code_end;
void caml_garbage_collection(void)
{
caml_young_limit = caml_young_start;
if (caml_young_ptr < caml_young_start || caml_force_major_slice) {
caml_minor_collection();
CAMLassert (caml_young_ptr >= caml_young_alloc_start);
caml_young_limit = caml_young_trigger;
if (caml_requested_major_slice || caml_requested_minor_gc ||
caml_young_ptr - caml_young_trigger < Max_young_whsize){
caml_gc_dispatch ();
}
caml_process_pending_signals();
}

11
asmrun/startup.c
View File

@ -107,14 +107,17 @@ void caml_main(char **argv)
caml_install_invalid_parameter_handler();
#endif
caml_init_custom_operations();
#ifdef DEBUG
caml_verb_gc = 63;
#endif
caml_top_of_stack = &tos;
#ifdef DEBUG
caml_verb_gc = 0x3F;
#endif
caml_parse_ocamlrunparam();
#ifdef DEBUG
caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0);
#endif
caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz,
caml_init_heap_chunk_sz, caml_init_percent_free,
caml_init_max_percent_free);
caml_init_max_percent_free, caml_init_major_window);
init_static();
caml_init_signals();
caml_init_backtrace();

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

0
asmcomp/debuginfo.ml → bytecomp/debuginfo.ml
View File

0
asmcomp/debuginfo.mli → bytecomp/debuginfo.mli
View File

2
bytecomp/lambda.ml
View File

@ -184,6 +184,7 @@ type shared_code = (int * int) list
type function_attribute = {
inline : inline_attribute;
is_a_functor: bool;
}
type lambda =
@ -245,6 +246,7 @@ let lambda_unit = Lconst const_unit
let default_function_attribute = {
inline = Default_inline;
is_a_functor = false;
}
(* Build sharing keys *)

1
bytecomp/lambda.mli
View File

@ -196,6 +196,7 @@ type shared_code = (int * int) list (* stack size -> code label *)
type function_attribute = {
inline : inline_attribute;
is_a_functor: bool;
}
type lambda =

98
bytecomp/printlambda.ml
View File

@ -261,7 +261,103 @@ let primitive ppf = function
| Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
| Pint_as_pointer -> fprintf ppf "int_as_pointer"
let function_attribute ppf { inline } =
let name_of_primitive = function
| Pidentity -> "Pidentity"
| Pignore -> "Pignore"
| Prevapply _ -> "Prevapply"
| Pdirapply _ -> "Pdirapply"
| Ploc _ -> "Ploc"
| Pgetglobal _ -> "Pgetglobal"
| Psetglobal _ -> "Psetglobal"
| Pmakeblock _ -> "Pmakeblock"
| Pfield _ -> "Pfield"
| Psetfield _ -> "Psetfield"
| Pfloatfield _ -> "Pfloatfield"
| Psetfloatfield _ -> "Psetfloatfield"
| Pduprecord _ -> "Pduprecord"
| Plazyforce -> "Plazyforce"
| Pccall _ -> "Pccall"
| Praise _ -> "Praise"
| Psequand -> "Psequand"
| Psequor -> "Psequor"
| Pnot -> "Pnot"
| Pnegint -> "Pnegint"
| Paddint -> "Paddint"
| Psubint -> "Psubint"
| Pmulint -> "Pmulint"
| Pdivint -> "Pdivint"
| Pmodint -> "Pmodint"
| Pandint -> "Pandint"
| Porint -> "Porint"
| Pxorint -> "Pxorint"
| Plslint -> "Plslint"
| Plsrint -> "Plsrint"
| Pasrint -> "Pasrint"
| Pintcomp _ -> "Pintcomp"
| Poffsetint _ -> "Poffsetint"
| Poffsetref _ -> "Poffsetref"
| Pintoffloat -> "Pintoffloat"
| Pfloatofint -> "Pfloatofint"
| Pnegfloat -> "Pnegfloat"
| Pabsfloat -> "Pabsfloat"
| Paddfloat -> "Paddfloat"
| Psubfloat -> "Psubfloat"
| Pmulfloat -> "Pmulfloat"
| Pdivfloat -> "Pdivfloat"
| Pfloatcomp _ -> "Pfloatcomp"
| Pstringlength -> "Pstringlength"
| Pstringrefu -> "Pstringrefu"
| Pstringsetu -> "Pstringsetu"
| Pstringrefs -> "Pstringrefs"
| Pstringsets -> "Pstringsets"
| Parraylength _ -> "Parraylength"
| Pmakearray _ -> "Pmakearray"
| Parrayrefu _ -> "Parrayrefu"
| Parraysetu _ -> "Parraysetu"
| Parrayrefs _ -> "Parrayrefs"
| Parraysets _ -> "Parraysets"
| Pctconst _ -> "Pctconst"
| Pisint -> "Pisint"
| Pisout -> "Pisout"
| Pbittest -> "Pbittest"
| Pbintofint _ -> "Pbintofint"
| Pintofbint _ -> "Pintofbint"
| Pcvtbint _ -> "Pcvtbint"
| Pnegbint _ -> "Pnegbint"
| Paddbint _ -> "Paddbint"
| Psubbint _ -> "Psubbint"
| Pmulbint _ -> "Pmulbint"
| Pdivbint _ -> "Pdivbint"
| Pmodbint _ -> "Pmodbint"
| Pandbint _ -> "Pandbint"
| Porbint _ -> "Porbint"
| Pxorbint _ -> "Pxorbint"
| Plslbint _ -> "Plslbint"
| Plsrbint _ -> "Plsrbint"
| Pasrbint _ -> "Pasrbint"
| Pbintcomp _ -> "Pbintcomp"
| Pbigarrayref _ -> "Pbigarrayref"
| Pbigarrayset _ -> "Pbigarrayset"
| Pbigarraydim _ -> "Pbigarraydim"
| Pstring_load_16 _ -> "Pstring_load_16"
| Pstring_load_32 _ -> "Pstring_load_32"
| Pstring_load_64 _ -> "Pstring_load_64"
| Pstring_set_16 _ -> "Pstring_set_16"
| Pstring_set_32 _ -> "Pstring_set_32"
| Pstring_set_64 _ -> "Pstring_set_64"
| Pbigstring_load_16 _ -> "Pbigstring_load_16"
| Pbigstring_load_32 _ -> "Pbigstring_load_32"
| Pbigstring_load_64 _ -> "Pbigstring_load_64"
| Pbigstring_set_16 _ -> "Pbigstring_set_16"
| Pbigstring_set_32 _ -> "Pbigstring_set_32"
| Pbigstring_set_64 _ -> "Pbigstring_set_64"
| Pbswap16 -> "Pbswap16"
| Pbbswap _ -> "Pbbswap"
| Pint_as_pointer -> "Pint_as_pointer"
let function_attribute ppf { inline; is_a_functor } =
if is_a_functor then
fprintf ppf "is_a_functor@ ";
match inline with
| Default_inline -> ()
| Always_inline -> fprintf ppf "always_inline@ "

1
bytecomp/printlambda.mli
View File

@ -17,3 +17,4 @@ open Format
val structured_constant: formatter -> structured_constant -> unit
val lambda: formatter -> lambda -> unit
val primitive: formatter -> primitive -> unit
val name_of_primitive : primitive -> string

25
bytecomp/translattribute.ml
View File

@ -73,7 +73,7 @@ let add_inline_attribute expr loc attributes =
Location.prerr_warning loc
(Warnings.Duplicated_attribute "inline")
end;
Lfunction { funct with attr = { inline = inline_attribute } }
Lfunction { funct with attr = { attr with inline = inline_attribute } }
| expr, (Always_inline | Never_inline) ->
Location.prerr_warning loc
(Warnings.Misplaced_attribute "inline");
@ -84,12 +84,18 @@ let add_inline_attribute expr loc attributes =
used to ensure that this expression is not misplaced: If it
appears on any expression, it is an error, otherwise it would
have been removed by this function *)
let get_inlined_attribute e =
let get_and_remove_inlined_attribute e =
let attribute_value, exp_attributes =
make_get_inline_attribute is_inlined_attribute e.exp_attributes
in
attribute_value, { e with exp_attributes }
let get_and_remove_inlined_attribute_on_module e =
let attribute_value, mod_attributes =
make_get_inline_attribute is_inlined_attribute e.mod_attributes
in
attribute_value, { e with mod_attributes }
(* It also remove the attribute from the expression, like
get_inlined_attribute *)
let get_tailcall_attribute e =
@ -125,3 +131,18 @@ let check_attribute e ({ txt; loc }, _) =
Location.prerr_warning loc
(Warnings.Misplaced_attribute txt)
| _ -> ()
let check_attribute_on_module e ({ txt; loc }, _) =
match txt with
| "inline" | "ocaml.inline" -> begin
match e.mod_desc with
| Tmod_functor _ -> ()
| _ ->
Location.prerr_warning loc
(Warnings.Misplaced_attribute txt)
end
| "inlined" | "ocaml.inlined" ->
(* Removed by the Texp_apply cases *)
Location.prerr_warning loc
(Warnings.Misplaced_attribute txt)
| _ -> ()

15
bytecomp/translattribute.mli
View File

@ -15,20 +15,29 @@ val check_attribute
-> string Location.loc * _
-> unit
val check_attribute_on_module
: Typedtree.module_expr
-> string Location.loc * _
-> unit
val add_inline_attribute
: Lambda.lambda
-> Location.t
-> Parsetree.attribute list
-> Parsetree.attributes
-> Lambda.lambda
val get_inline_attribute
: (string Location.loc * Parsetree.payload) list
: Parsetree.attributes
-> Lambda.inline_attribute
val get_inlined_attribute
val get_and_remove_inlined_attribute
: Typedtree.expression
-> Lambda.inline_attribute * Typedtree.expression
val get_and_remove_inlined_attribute_on_module
: Typedtree.module_expr
-> Lambda.inline_attribute * Typedtree.module_expr
val get_tailcall_attribute
: Typedtree.expression
-> bool * Typedtree.expression

5
bytecomp/translcore.ml
View File

@ -692,6 +692,7 @@ and transl_exp0 e =
transl_function e.exp_loc !Clflags.native_code repr partial pl)
in
let attr = {
default_function_attribute with
inline = Translattribute.get_inline_attribute e.exp_attributes;
}
in
@ -709,7 +710,7 @@ and transl_exp0 e =
Translattribute.get_tailcall_attribute funct
in
let inlined, funct =
Translattribute.get_inlined_attribute funct
Translattribute.get_and_remove_inlined_attribute funct
in
let e = { e with exp_desc = Texp_apply(funct, oargs) } in
event_after e (transl_apply ~should_be_tailcall ~inlined
@ -765,7 +766,7 @@ and transl_exp0 e =
Translattribute.get_tailcall_attribute funct
in
let inlined, funct =
Translattribute.get_inlined_attribute funct
Translattribute.get_and_remove_inlined_attribute funct
in
let e = { e with exp_desc = Texp_apply(funct, oargs) } in
event_after e (transl_apply ~should_be_tailcall ~inlined

126
bytecomp/translmod.ml
View File

@ -91,7 +91,8 @@ let rec apply_coercion strict restr arg =
let param = Ident.create "funarg" in
name_lambda strict arg (fun id ->
Lfunction{kind = Curried; params = [param];
attr = default_function_attribute;
attr = { default_function_attribute with
is_a_functor = true };
body = apply_coercion
Strict cc_res
(Lapply{ap_should_be_tailcall=false;
@ -348,6 +349,8 @@ let transl_class_bindings cl_list =
(* Compile a module expression *)
let rec transl_module cc rootpath mexp =
List.iter (Translattribute.check_attribute_on_module mexp)
mexp.mod_attributes;
match mexp.mod_type with
Mty_alias _ -> apply_coercion Alias cc lambda_unit
| _ ->
@ -356,19 +359,24 @@ let rec transl_module cc rootpath mexp =
apply_coercion Strict cc
(transl_path ~loc:mexp.mod_loc mexp.mod_env path)
| Tmod_structure str ->
transl_struct [] cc rootpath str
fst (transl_struct [] cc rootpath str)
| Tmod_functor( param, _, mty, body) ->
let bodypath = functor_path rootpath param in
let inline_attribute =
Translattribute.get_inline_attribute mexp.mod_attributes
in
oo_wrap mexp.mod_env true
(function
| Tcoerce_none ->
Lfunction{kind = Curried; params = [param];
attr = default_function_attribute;
attr = { inline = inline_attribute;
is_a_functor = true };
body = transl_module Tcoerce_none bodypath body}
| Tcoerce_functor(ccarg, ccres) ->
let param' = Ident.create "funarg" in
Lfunction{kind = Curried; params = [param'];
attr = default_function_attribute;
attr = { inline = inline_attribute;
is_a_functor = true };
body = Llet(Alias, param,
apply_coercion Alias ccarg (Lvar param'),
transl_module ccres bodypath body)}
@ -376,13 +384,16 @@ let rec transl_module cc rootpath mexp =
fatal_error "Translmod.transl_module")
cc
| Tmod_apply(funct, arg, ccarg) ->
let inlined_attribute, funct =
Translattribute.get_and_remove_inlined_attribute_on_module funct
in
oo_wrap mexp.mod_env true
(apply_coercion Strict cc)
(Lapply{ap_should_be_tailcall=false;
ap_loc=mexp.mod_loc;
ap_func=transl_module Tcoerce_none None funct;
ap_args=[transl_module ccarg None arg];
ap_inlined=Default_inline})
ap_inlined=inlined_attribute})
| Tmod_constraint(arg, mty, _, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
@ -396,7 +407,8 @@ and transl_structure fields cc rootpath = function
begin match cc with
Tcoerce_none ->
Lprim(Pmakeblock(0, Immutable),
List.map (fun id -> Lvar id) (List.rev fields))
List.map (fun id -> Lvar id) (List.rev fields)),
List.length fields
| Tcoerce_structure(pos_cc_list, id_pos_list) ->
(* Do not ignore id_pos_list ! *)
(*Format.eprintf "%a@.@[" Includemod.print_coercion cc;
@ -419,18 +431,20 @@ and transl_structure fields cc rootpath = function
and id_pos_list =
List.filter (fun (id,_,_) -> not (IdentSet.mem id ids)) id_pos_list
in
wrap_id_pos_list id_pos_list get_field lam
wrap_id_pos_list id_pos_list get_field lam,
List.length pos_cc_list
| _ ->
fatal_error "Translmod.transl_structure"
end
| item :: rem ->
match item.str_desc with
| Tstr_eval (expr, _) ->
Lsequence(transl_exp expr, transl_structure fields cc rootpath rem)
let body, size = transl_structure fields cc rootpath rem in
Lsequence(transl_exp expr, body), size
| Tstr_value(rec_flag, pat_expr_list) ->
let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
transl_let rec_flag pat_expr_list
(transl_structure ext_fields cc rootpath rem)
let body, size = transl_structure ext_fields cc rootpath rem in
transl_let rec_flag pat_expr_list body, size
| Tstr_primitive descr ->
record_primitive descr.val_val;
transl_structure fields cc rootpath rem
@ -438,31 +452,47 @@ and transl_structure fields cc rootpath = function
transl_structure fields cc rootpath rem
| Tstr_typext(tyext) ->
let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
transl_type_extension item.str_env rootpath tyext
(transl_structure (List.rev_append ids fields) cc rootpath rem)
let body, size =
transl_structure (List.rev_append ids fields) cc rootpath rem
in
transl_type_extension item.str_env rootpath tyext body, size
| Tstr_exception ext ->
let id = ext.ext_id in
let path = field_path rootpath id in
let body, size = transl_structure (id :: fields) cc rootpath rem in
Llet(Strict, id, transl_extension_constructor item.str_env path ext,
transl_structure (id :: fields) cc rootpath rem)
body), size
| Tstr_module mb ->
let id = mb.mb_id in
let body, size = transl_structure (id :: fields) cc rootpath rem in
let module_body =
transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
in
let module_body =
Translattribute.add_inline_attribute module_body mb.mb_loc mb.mb_attributes
in
Llet(pure_module mb.mb_expr, id,
transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr,
transl_structure (id :: fields) cc rootpath rem)
module_body,
body), size
| Tstr_recmodule bindings ->
let ext_fields =
List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields
in
compile_recmodule
(fun id modl ->
transl_module Tcoerce_none (field_path rootpath id) modl)
bindings
(transl_structure ext_fields cc rootpath rem)
let body, size = transl_structure ext_fields cc rootpath rem in
let lam =
compile_recmodule
(fun id modl ->
transl_module Tcoerce_none (field_path rootpath id) modl)
bindings
body
in
lam, size
| Tstr_class cl_list ->
let (ids, class_bindings) = transl_class_bindings cl_list in
Lletrec(class_bindings,
transl_structure (List.rev_append ids fields) cc rootpath rem)
let body, size =
transl_structure (List.rev_append ids fields) cc rootpath rem
in
Lletrec(class_bindings, body), size
| Tstr_include incl ->
let ids = bound_value_identifiers incl.incl_type in
let modl = incl.incl_mod in
@ -471,10 +501,12 @@ and transl_structure fields cc rootpath = function
[] ->
transl_structure newfields cc rootpath rem
| id :: ids ->
Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]),
rebind_idents (pos + 1) (id :: newfields) ids) in
let body, size = rebind_idents (pos + 1) (id :: newfields) ids in
Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), body), size
in
let body, size = rebind_idents 0 fields ids in
Llet(pure_module modl, mid, transl_module Tcoerce_none None modl,
rebind_idents 0 fields ids)
body), size
| Tstr_modtype _
| Tstr_open _
@ -526,16 +558,22 @@ let wrap_globals body =
(* Compile an implementation *)
let transl_implementation module_name (str, cc) =
let transl_implementation_flambda module_name (str, cc) =
reset_labels ();
primitive_declarations := [];
Hashtbl.clear used_primitives;
let module_id = Ident.create_persistent module_name in
let body =
let body, size =
transl_label_init
(transl_struct [] cc (global_path module_id) str) in
Lprim(Psetglobal module_id, [wrap_globals body])
(fun () -> transl_struct [] cc (global_path module_id) str)
in
module_id, (wrap_globals body, size)
let transl_implementation module_name (str, cc) =
let module_id, (module_initializer, _size) =
transl_implementation_flambda module_name (str, cc)
in
Lprim (Psetglobal module_id, [module_initializer])
(* Build the list of value identifiers defined by a toplevel structure
(excluding primitive declarations). *)
@ -671,7 +709,11 @@ let transl_store_structure glob map prims str =
let lam = transl_extension_constructor item.str_env path ext in
Lsequence(Llet(Strict, id, subst_lambda subst lam, store_ident id),
transl_store rootpath (add_ident false id subst) rem)
| Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} ->
| Tstr_module{mb_id=id;
mb_expr={mod_desc = Tmod_structure str} as mexp;
mb_attributes} ->
List.iter (Translattribute.check_attribute_on_module mexp)
mb_attributes;
let lam = transl_store (field_path rootpath id) subst str.str_items in
(* Careful: see next case *)
let subst = !transl_store_subst in
@ -684,8 +726,17 @@ let transl_store_structure glob map prims str =
Lsequence(store_ident id,
transl_store rootpath (add_ident true id subst)
rem)))
| Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, (Tcoerce_structure (map, _) as _cc))}} ->
| Tstr_module{
mb_id=id;
mb_expr= {
mod_desc = Tmod_constraint (
{mod_desc = Tmod_structure str} as mexp, _, _,
(Tcoerce_structure (map, _) as _cc))};
mb_attributes
} ->
(* Format.printf "coerc id %s: %a@." (Ident.unique_name id) Includemod.print_coercion cc; *)
List.iter (Translattribute.check_attribute_on_module mexp)
mb_attributes;
let lam = transl_store (field_path rootpath id) subst str.str_items in
(* Careful: see next case *)
let subst = !transl_store_subst in
@ -704,8 +755,12 @@ let transl_store_structure glob map prims str =
Lsequence(store_ident id,
transl_store rootpath (add_ident true id subst)
rem)))
| Tstr_module{mb_id=id; mb_expr=modl} ->
let lam = transl_module Tcoerce_none (field_path rootpath id) modl in
| Tstr_module{mb_id=id; mb_expr=modl; mb_loc; mb_attributes} ->
let lam =
Translattribute.add_inline_attribute
(transl_module Tcoerce_none (field_path rootpath id) modl)
mb_loc mb_attributes
in
(* Careful: the module value stored in the global may be different
from the local module value, in case a coercion is applied.
If so, keep using the local module value (id) in the remainder of
@ -884,7 +939,7 @@ let toploop_setvalue id lam =
let toploop_setvalue_id id = toploop_setvalue id (Lvar id)
let close_toplevel_term lam =
let close_toplevel_term (lam, ()) =
IdentSet.fold (fun id l -> Llet(Strict, id, toploop_getvalue id, l))
(free_variables lam) lam
@ -953,7 +1008,8 @@ let transl_toplevel_item item =
lambda_unit
let transl_toplevel_item_and_close itm =
close_toplevel_term (transl_label_init (transl_toplevel_item itm))
close_toplevel_term
(transl_label_init (fun () -> transl_toplevel_item itm, ()))
let transl_toplevel_definition str =
reset_labels ();

11
bytecomp/translobj.ml
View File

@ -91,7 +91,8 @@ let prim_makearray =
Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true
(* Also use it for required globals *)
let transl_label_init expr =
let transl_label_init_general f =
let expr, size = f () in
let expr =
Hashtbl.fold
(fun c id expr -> Llet(Alias, id, Lconst c, expr))
@ -104,7 +105,7 @@ let transl_label_init expr =
in
Env.reset_required_globals ();*)
reset_labels ();
expr
expr, size
let transl_store_label_init glob size f arg =
method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]);
@ -118,7 +119,11 @@ let transl_store_label_init glob size f arg =
Lprim (Pccall prim_makearray, [int !method_count; int 0])]),
expr))
in
(size, transl_label_init expr)
let lam, size = transl_label_init_general (fun () -> (expr, size)) in
size, lam
let transl_label_init f =
transl_label_init_general f
(* Share classes *)

2
bytecomp/translobj.mli
View File

@ -18,7 +18,7 @@ val share: structured_constant -> lambda
val meth: lambda -> string -> lambda * lambda list
val reset_labels: unit -> unit
val transl_label_init: lambda -> lambda
val transl_label_init: (unit -> lambda * 'a) -> lambda * 'a
val transl_store_label_init:
Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda

1514
byterun/.depend
View File

File diff suppressed because it is too large Load Diff

17
byterun/Makefile
View File

@ -15,9 +15,11 @@ include Makefile.common
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)
@ -30,6 +32,9 @@ 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
@ -38,6 +43,10 @@ libcamlrund.a: $(DOBJS)
$(ARCMD) rc libcamlrund.a $(DOBJS)
$(RANLIB) libcamlrund.a
libcamlruni.a: $(IOBJS)
$(ARCMD) rc $@ $^
$(RANLIB) $@
all-noshared:
.PHONY: all-noshared
@ -68,12 +77,18 @@ clean::
%.d.o: %.c
$(CC) -c $(DFLAGS) $< -o $@
%.i.o: %.c
$(CC) -c $(IFLAGS) -o $@ $<
%.pic.o: %.c
$(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $< -o $@
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/' >> .depend
-$(CC) -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' \
>> .depend
-$(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

10
byterun/Makefile.common
View File

@ -48,6 +48,10 @@ 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
@ -84,6 +88,12 @@ install-runtimed:
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

11
byterun/array.c
View File

@ -18,6 +18,7 @@
#include "caml/memory.h"
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "caml/signals.h"
/* returns number of elements (either fields or floats) */
CAMLexport mlsize_t caml_array_length(value array)
@ -181,12 +182,16 @@ CAMLprim value caml_make_vect(value len, value init)
}
} else {
if (size > Max_wosize) caml_invalid_argument("Array.make");
if (size < Max_young_wosize) {
if (size <= Max_young_wosize) {
res = caml_alloc_small(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
}
else if (Is_block(init) && Is_young(init)) {
caml_minor_collection();
/* We don't want to create so many major-to-minor references,
so [init] is moved to the major heap by doing a minor GC. */
CAML_INSTR_INT ("force_minor/make_vect@", 1);
caml_request_minor_gc ();
caml_gc_dispatch ();
res = caml_alloc_shr(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
res = caml_check_urgent_gc (res);
@ -324,7 +329,7 @@ static value caml_array_gather(intnat num_arrays,
/* Array of values, too big. */
caml_invalid_argument("Array.concat");
}
else if (size < Max_young_wosize) {
else if (size <= Max_young_wosize) {
/* Array of values, small enough to fit in young generation.
We can use memcpy directly. */
res = caml_alloc_small(size, 0);

1
byterun/caml/address_class.h
View File

@ -16,6 +16,7 @@
#ifndef CAML_ADDRESS_CLASS_H
#define CAML_ADDRESS_CLASS_H
#include "config.h"
#include "misc.h"
#include "mlvalues.h"

11
byterun/caml/config.h
View File

@ -112,6 +112,7 @@ typedef uint64_t uintnat;
#define ARCH_FLOAT_ENDIANNESS 0x01234567
#endif
/* We use threaded code interpretation if the compiler provides labels
as first-class values (GCC 2.x). */
@ -143,10 +144,11 @@ typedef uint64_t uintnat;
/* Maximum size of a block allocated in the young generation (words). */
/* Must be > 4 */
#define Max_young_wosize 256
#define Max_young_whsize (Whsize_wosize (Max_young_wosize))
/* Minimum size of the minor zone (words).
This must be at least [Max_young_wosize + 1]. */
This must be at least [2 * Max_young_whsize]. */
#define Minor_heap_min 4096
/* Maximum size of the minor zone (words).
@ -185,5 +187,12 @@ typedef uint64_t uintnat;
*/
#define Max_percent_free_def 500
/* Default setting for the major GC slice smoothing window: 1
(i.e. no smoothing)
*/
#define Major_window_def 1
/* Maximum size of the major GC slice smoothing window. */
#define Max_major_window 50
#endif /* CAML_CONFIG_H */

12
byterun/caml/gc_ctrl.h
View File

@ -31,8 +31,16 @@ extern intnat
uintnat caml_normalize_heap_increment (uintnat);
void caml_init_gc (uintnat, uintnat, uintnat,
uintnat, uintnat);
/*
minor_size: cf. minor_heap_size in gc.mli
major_size: Size in words of the initial major heap
major_incr: cf. major_heap_increment in gc.mli
percent_fr: cf. space_overhead in gc.mli
percent_m : cf. max_overhead in gc.mli
window : cf. window_size in gc.mli
*/
void caml_init_gc (uintnat minor_size, uintnat major_size, uintnat major_incr,
uintnat percent_fr, uintnat percent_m, uintnat window);
#ifdef DEBUG

1
byterun/caml/instrtrace.h
View File

@ -20,7 +20,6 @@
#include "mlvalues.h"
#include "misc.h"
extern int caml_trace_flag;
extern intnat caml_icount;
void caml_stop_here (void);
void caml_disasm_instr (code_t pc);

20
byterun/caml/major_gc.h
View File

@ -40,21 +40,29 @@ extern uintnat caml_fl_wsz_at_phase_change;
#define Phase_mark 0
#define Phase_sweep 1
#define Phase_idle 2
#define Subphase_main 10
#define Subphase_weak1 11
#define Subphase_weak2 12
#define Subphase_final 13
#define Subphase_roots 10
#define Subphase_main 11
#define Subphase_weak1 12
#define Subphase_weak2 13
#define Subphase_final 14
CAMLextern char *caml_heap_start;
extern uintnat total_heap_size;
extern char *caml_gc_sweep_hp;
extern int caml_major_window;
double caml_major_ring[Max_major_window];
int caml_major_ring_index;
double caml_major_work_credit;
extern double caml_gc_clock;
void caml_init_major_heap (asize_t); /* size in bytes */
asize_t caml_round_heap_chunk_wsz (asize_t);
asize_t caml_clip_heap_chunk_wsz (asize_t wsz);
void caml_darken (value, value *);
intnat caml_major_collection_slice (intnat);
void caml_major_collection_slice (intnat);
void major_collection (void);
void caml_finish_major_cycle (void);
void caml_set_major_window (int);
#endif /* CAML_MAJOR_GC_H */

30
byterun/caml/memory.h
View File

@ -44,15 +44,32 @@ CAMLextern value caml_check_urgent_gc (value);
CAMLextern void * caml_stat_alloc (asize_t); /* Size in bytes. */
CAMLextern void caml_stat_free (void *);
CAMLextern void * caml_stat_resize (void *, asize_t); /* Size in bytes. */
char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */
void caml_free_for_heap (char *mem);
int caml_add_to_heap (char *mem);
color_t caml_allocation_color (void *hp);
CAMLextern int caml_init_alloc_for_heap (void);
CAMLextern char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */
CAMLextern void caml_free_for_heap (char *mem);
CAMLextern int caml_add_to_heap (char *mem);
CAMLextern color_t caml_allocation_color (void *hp);
CAMLextern int caml_huge_fallback_count;
/* void caml_shrink_heap (char *); Only used in compact.c */
/* <private> */
extern uintnat caml_use_huge_pages;
#ifdef HAS_HUGE_PAGES
#include <sys/mman.h>
#define Heap_page_size HUGE_PAGE_SIZE
#define Round_mmap_size(x) \
(((x) + (Heap_page_size - 1)) & ~ (Heap_page_size - 1))
#endif
int caml_page_table_add(int kind, void * start, void * end);
int caml_page_table_remove(int kind, void * start, void * end);
int caml_page_table_initialize(mlsize_t bytesize);
#ifdef DEBUG
#define DEBUG_clear(result, wosize) do{ \
uintnat caml__DEBUG_i; \
@ -68,10 +85,11 @@ color_t caml_allocation_color (void *hp);
CAMLassert ((tag_t) (tag) < 256); \
CAMLassert ((wosize) <= Max_young_wosize); \
caml_young_ptr -= Whsize_wosize (wosize); \
if (caml_young_ptr < caml_young_start){ \
if (caml_young_ptr < caml_young_trigger){ \
caml_young_ptr += Whsize_wosize (wosize); \
CAML_INSTR_INT ("force_minor/alloc_small@", 1); \
Setup_for_gc; \
caml_minor_collection (); \
caml_gc_dispatch (); \
Restore_after_gc; \
caml_young_ptr -= Whsize_wosize (wosize); \
} \

18
byterun/caml/minor_gc.h
View File

@ -16,9 +16,12 @@
#include "address_class.h"
#include "config.h"
CAMLextern value *caml_young_start, *caml_young_ptr;
CAMLextern value *caml_young_end, *caml_young_limit;
CAMLextern value *caml_young_start, *caml_young_end;
CAMLextern value *caml_young_alloc_start, *caml_young_alloc_end;
CAMLextern value *caml_young_ptr, *caml_young_limit;
CAMLextern value *caml_young_trigger;
extern asize_t caml_minor_heap_wsz;
extern int caml_in_minor_collection;
@ -36,7 +39,7 @@ CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table,
extern void caml_set_minor_heap_size (asize_t); /* size in bytes */
extern void caml_empty_minor_heap (void);
CAMLextern void caml_minor_collection (void);
CAMLextern void caml_gc_dispatch (void);
CAMLextern void garbage_collection (void); /* def in asmrun/signals_asm.c */
extern void caml_realloc_ref_table (struct caml_ref_table *);
extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t);
@ -50,4 +53,13 @@ extern void caml_oldify_mopup (void);
} \
}while(0)
static inline void add_to_ref_table (struct caml_ref_table *tbl, value *p)
{
if (tbl->ptr >= tbl->limit){
CAMLassert (tbl->ptr == tbl->limit);
caml_realloc_ref_table (tbl);
}
*tbl->ptr++ = p;
}
#endif /* CAML_MINOR_GC_H */

100
byterun/caml/misc.h
View File

@ -196,11 +196,109 @@ extern void caml_set_fields (intnat v, unsigned long, unsigned long);
/* snprintf emulation for Win32 */
#ifdef _WIN32
#if defined(_WIN32) && !defined(_UCRT)
extern int caml_snprintf(char * buf, size_t size, const char * format, ...);
#define snprintf caml_snprintf
#endif
#ifdef CAML_INSTR
/* Timers and counters for GC latency profiling (Linux-only) */
#include <time.h>
#include <stdio.h>
extern intnat caml_stat_minor_collections;
extern intnat CAML_INSTR_STARTTIME, CAML_INSTR_STOPTIME;
struct CAML_INSTR_BLOCK {
struct timespec ts[10];
char *tag[10];
int index;
struct CAML_INSTR_BLOCK *next;
};
extern struct CAML_INSTR_BLOCK *CAML_INSTR_LOG;
/* Declare a timer/counter name. [t] must be a new variable name. */
#define CAML_INSTR_DECLARE(t) \
struct CAML_INSTR_BLOCK *t = NULL
/* Allocate the data block for a given name.
[t] must have been declared with [CAML_INSTR_DECLARE]. */
#define CAML_INSTR_ALLOC(t) do{ \
if (caml_stat_minor_collections >= CAML_INSTR_STARTTIME \
&& caml_stat_minor_collections < CAML_INSTR_STOPTIME){ \
t = malloc (sizeof (struct CAML_INSTR_BLOCK)); \
t->index = 0; \
t->tag[0] = ""; \
t->next = CAML_INSTR_LOG; \
CAML_INSTR_LOG = t; \
} \
}while(0)
/* Allocate the data block and start the timer.
[t] must have been declared with [CAML_INSTR_DECLARE]
and allocated with [CAML_INSTR_ALLOC]. */
#define CAML_INSTR_START(t, msg) do{ \
if (t != NULL){ \
t->tag[0] = msg; \
clock_gettime (CLOCK_REALTIME, &(t->ts[0])); \
} \
}while(0)
/* Declare a timer, allocate its data, and start it.
[t] must be a new variable name. */
#define CAML_INSTR_SETUP(t, msg) \
CAML_INSTR_DECLARE (t); \
CAML_INSTR_ALLOC (t); \
CAML_INSTR_START (t, msg)
/* Record an intermediate time within a given timer.
[t] must have been declared, allocated, and started. */
#define CAML_INSTR_TIME(t, msg) do{ \
if (t != NULL){ \
++ t->index; \
t->tag[t->index] = (msg); \
clock_gettime (CLOCK_REALTIME, &(t->ts[t->index])); \
} \
}while(0)
/* Record an integer data point.
If [msg] ends with # it will be interpreted as an integer-valued event.
If it ends with @ it will be interpreted as an event counter.
*/
#define CAML_INSTR_INT(msg, data) do{ \
CAML_INSTR_SETUP (__caml_tmp, ""); \
if (__caml_tmp != NULL){ \
__caml_tmp->index = 1; \
__caml_tmp->tag[1] = msg; \
__caml_tmp->ts[1].tv_sec = 0; \
__caml_tmp->ts[1].tv_nsec = (data); \
} \
}while(0)
/* This function is called at the start of the program to set up
the data for the above macros.
*/
extern void CAML_INSTR_INIT (void);
/* This function is automatically called by the runtime to output
the collected data to the dump file. */
extern void CAML_INSTR_ATEXIT (void);
#else /* CAML_INSTR */
#define CAML_INSTR_DECLARE(t) /**/
#define CAML_INSTR_ALLOC(t) /**/
#define CAML_INSTR_START(t, name) /**/
#define CAML_INSTR_SETUP(t, name) /**/
#define CAML_INSTR_TIME(t, msg) /**/
#define CAML_INSTR_INT(msg, c) /**/
#define CAML_INSTR_INIT() /**/
#define CAML_INSTR_ATEXIT() /**/
#endif /* CAML_INSTR */
/* </private> */
#ifdef __cplusplus

5
byterun/caml/mlvalues.h
View File

@ -217,7 +217,8 @@ CAMLextern value caml_hash_variant(char const * tag);
#define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */
/* Abstract things. Their contents is not traced by the GC; therefore they
must not contain any [value].
must not contain any [value]. Must have odd number so that headers with
this tag cannot be mistaken for pointers (see caml_obj_truncate).
*/
#define Abstract_tag 251
@ -304,6 +305,4 @@ CAMLextern value caml_set_oo_id(value obj);
}
#endif
extern intnat caml_stat_top_heap_wsz;
#endif /* CAML_MLVALUES_H */

6
byterun/caml/roots.h
View File

@ -20,8 +20,10 @@
typedef void (*scanning_action) (value, value *);
void caml_oldify_local_roots (void);
void caml_darken_all_roots (void);
void caml_do_roots (scanning_action);
void caml_darken_all_roots_start (void);
intnat caml_darken_all_roots_slice (intnat);
void caml_do_roots (scanning_action, int);
extern uintnat caml_incremental_roots_count;
#ifndef NATIVE_CODE
CAMLextern void caml_do_local_roots (scanning_action, value *, value *,
struct caml__roots_block *);

6
byterun/caml/signals.h
View File

@ -28,14 +28,16 @@ extern "C" {
CAMLextern intnat volatile caml_signals_are_pending;
CAMLextern intnat volatile caml_pending_signals[];
CAMLextern int volatile caml_something_to_do;
extern int volatile caml_force_major_slice;
extern int volatile caml_requested_major_slice;
extern int volatile caml_requested_minor_gc;
/* </private> */
CAMLextern void caml_enter_blocking_section (void);
CAMLextern void caml_leave_blocking_section (void);
/* <private> */
void caml_urge_major_slice (void);
void caml_request_major_slice (void);
void caml_request_minor_gc (void);
CAMLextern int caml_convert_signal_number (int);
CAMLextern int caml_rev_convert_signal_number (int);
void caml_execute_signal(int signal_number, int in_signal_handler);

1
byterun/caml/startup_aux.h
View File

@ -21,6 +21,7 @@ extern uintnat caml_init_minor_heap_wsz;
extern uintnat caml_init_heap_chunk_sz;
extern uintnat caml_init_heap_wsz;
extern uintnat caml_init_max_stack_wsz;
extern uintnat caml_init_major_window;
extern uintnat caml_trace_level;
extern void caml_parse_ocamlrunparam (void);

29
byterun/compact.c
View File

@ -185,7 +185,7 @@ static void do_compaction (void)
/* Invert roots first because the threads library needs some heap
data structures to find its roots. Fortunately, it doesn't need
the headers (see above). */
caml_do_roots (invert_root);
caml_do_roots (invert_root, 1);
caml_final_do_weak_roots (invert_root);
ch = caml_heap_start;
@ -398,8 +398,14 @@ uintnat caml_percent_max; /* used in gc_ctrl.c and memory.c */
void caml_compact_heap (void)
{
uintnat target_wsz, live;
CAML_INSTR_SETUP(tmr, "compact");
CAMLassert (caml_young_ptr == caml_young_alloc_end);
CAMLassert (caml_ref_table.ptr == caml_ref_table.base);
CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.base);
do_compaction ();
CAML_INSTR_TIME (tmr, "compact/main");
/* Compaction may fail to shrink the heap to a reasonable size
because it deals in complete chunks: if a very large chunk
is at the beginning of the heap, everything gets moved to
@ -428,8 +434,16 @@ void caml_compact_heap (void)
live = caml_stat_heap_wsz - caml_fl_cur_wsz;
target_wsz = live + caml_percent_free * (live / 100 + 1)
+ Wsize_bsize (Page_size);
target_wsz = caml_round_heap_chunk_wsz (target_wsz);
target_wsz = caml_clip_heap_chunk_wsz (target_wsz);
#ifdef HAS_HUGE_PAGES
if (caml_use_huge_pages
&& Bsize_wsize (caml_stat_heap_wsz) <= HUGE_PAGE_SIZE)
return;
#endif
if (target_wsz < caml_stat_heap_wsz / 2){
/* Recompact. */
char *chunk;
caml_gc_message (0x10, "Recompacting heap (target=%luk words)\n",
@ -456,6 +470,7 @@ void caml_compact_heap (void)
Assert (caml_stat_heap_chunks == 1);
Assert (Chunk_next (caml_heap_start) == NULL);
Assert (caml_stat_heap_wsz == Wsize_bsize (Chunk_size (chunk)));
CAML_INSTR_TIME (tmr, "compact/recompact");
}
}
@ -473,7 +488,13 @@ void caml_compact_heap_maybe (void)
Assert (caml_gc_phase == Phase_idle);
if (caml_percent_max >= 1000000) return;
if (caml_stat_major_collections < 3) return;
if (caml_stat_heap_wsz <= 2 * caml_round_heap_chunk_wsz (0)) return;
if (caml_stat_heap_wsz <= 2 * caml_clip_heap_chunk_wsz (0)) return;
#ifdef HAS_HUGE_PAGES
if (caml_use_huge_pages
&& Bsize_wsize (caml_stat_heap_wsz) <= HUGE_PAGE_SIZE)
return;
#endif
fw = 3.0 * caml_fl_cur_wsz - 2.0 * caml_fl_wsz_at_phase_change;
if (fw < 0) fw = caml_fl_cur_wsz;
@ -492,9 +513,9 @@ void caml_compact_heap_maybe (void)
(uintnat) fp);
if (fp >= caml_percent_max){
caml_gc_message (0x200, "Automatic compaction triggered.\n", 0);
caml_empty_minor_heap (); /* minor heap must be empty for compaction */
caml_finish_major_cycle ();
/* We just did a complete GC, so we can measure the overhead exactly. */
fw = caml_fl_cur_wsz;
fp = 100.0 * fw / (caml_stat_heap_wsz - fw);
caml_gc_message (0x200, "Measured overhead: %"

5
byterun/extern.c
View File

@ -17,6 +17,7 @@
#include <string.h>
#include "caml/alloc.h"
#include "caml/config.h"
#include "caml/custom.h"
#include "caml/fail.h"
#include "caml/gc.h"
@ -28,10 +29,6 @@
#include "caml/mlvalues.h"
#include "caml/reverse.h"
#ifdef _MSC_VER
#define inline _inline
#endif
static uintnat obj_counter; /* Number of objects emitted so far */
static uintnat size_32; /* Size in words of 32-bit block for struct. */
static uintnat size_64; /* Size in words of 64-bit block for struct. */

56
byterun/finalise.c
View File

@ -59,16 +59,15 @@ static void alloc_to_do (int size)
}
}
/* Find white finalisable values, put them in the finalising set, and
/* Find white finalisable values, move them to the finalising set, and
darken them.
The recent set is empty.
*/
void caml_final_update (void)
{
uintnat i, j, k;
uintnat todo_count = 0;
Assert (young == old);
Assert (old <= young);
for (i = 0; i < old; i++){
Assert (Is_block (final_table[i].val));
Assert (Is_in_heap (final_table[i].val));
@ -79,35 +78,25 @@ void caml_final_update (void)
alloc_to_do (todo_count);
j = k = 0;
for (i = 0; i < old; i++){
again:
Assert (Is_block (final_table[i].val));
Assert (Is_in_heap (final_table[i].val));
Assert (Tag_val (final_table[i].val) != Forward_tag);
if (Is_white_val (final_table[i].val)){
if (Tag_val (final_table[i].val) == Forward_tag){
value fv;
Assert (final_table[i].offset == 0);
fv = Forward_val (final_table[i].val);
if (Is_block (fv)
&& (!Is_in_value_area(fv) || Tag_val (fv) == Forward_tag
|| Tag_val (fv) == Lazy_tag || Tag_val (fv) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
final_table[i].val = fv;
if (Is_block (final_table[i].val)
&& Is_in_heap (final_table[i].val)){
goto again;
}
}
}
to_do_tl->item[k++] = final_table[i];
}else{
final_table[j++] = final_table[i];
}
}
young = old = j;
CAMLassert (i == old);
old = j;
for(;i < young; i++){
final_table[j++] = final_table[i];
}
young = j;
to_do_tl->size = k;
for (i = 0; i < k; i++){
CAMLassert (Is_white_val (to_do_tl->item[i].val));
/* Note that item may already be dark due to multiple entries in
the final table. */
caml_darken (to_do_tl->item[i].val, NULL);
}
}
@ -124,7 +113,7 @@ void caml_final_do_calls (void)
value res;
if (running_finalisation_function) return;
if (caml_finalise_begin_hook != NULL) (*caml_finalise_begin_hook) ();
if (to_do_hd != NULL){
if (caml_finalise_begin_hook != NULL) (*caml_finalise_begin_hook) ();
caml_gc_message (0x80, "Calling finalisation functions.\n", 0);
@ -147,6 +136,7 @@ void caml_final_do_calls (void)
caml_gc_message (0x80, "Done calling finalisation functions.\n", 0);
if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) ();
}
if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) ();
}
/* Call a scanning_action [f] on [x]. */
@ -154,17 +144,15 @@ void caml_final_do_calls (void)
/* Call [*f] on the closures of the finalisable set and
the closures and values of the finalising set.
The recent set is empty.
This is called by the major GC and the compactor
through [caml_darken_all_roots].
This is called by the major GC through [caml_darken_all_roots].
*/
void caml_final_do_strong_roots (scanning_action f)
{
uintnat i;
struct to_do *todo;
Assert (old == young);
for (i = 0; i < old; i++) Call_action (f, final_table[i].fun);
Assert (old <= young);
for (i = 0; i < young; i++) Call_action (f, final_table[i].fun);
for (todo = to_do_hd; todo != NULL; todo = todo->next){
for (i = 0; i < todo->size; i++){
@ -175,15 +163,14 @@ void caml_final_do_strong_roots (scanning_action f)
}
/* Call [*f] on the values of the finalisable set.
The recent set is empty.
This is called directly by the compactor.
*/
void caml_final_do_weak_roots (scanning_action f)
{
uintnat i;
Assert (old == young);
for (i = 0; i < old; i++) Call_action (f, final_table[i].val);
CAMLassert (old <= young);
for (i = 0; i < young; i++) Call_action (f, final_table[i].val);
}
/* Call [*f] on the closures and values of the recent set.
@ -213,9 +200,10 @@ void caml_final_empty_young (void)
CAMLprim value caml_final_register (value f, value v)
{
if (!Is_block (v)
|| !Is_in_heap_or_young(v)
|| Tag_val (v) == Lazy_tag
|| Tag_val (v) == Double_tag) {
|| !Is_in_heap_or_young(v)
|| Tag_val (v) == Lazy_tag
|| Tag_val (v) == Double_tag
|| Tag_val (v) == Forward_tag) {
caml_invalid_argument ("Gc.finalise");
}
Assert (old <= young);

52
byterun/freelist.c
View File

@ -148,6 +148,35 @@ static header_t *allocate_block (mlsize_t wh_sz, int flpi, value prev,
return (header_t *) &Field (cur, Wosize_hd (h) - wh_sz);
}
#ifdef CAML_INSTR
static uintnat instr_size [20] =
{0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0};
static char *instr_name [20] = {
NULL,
"alloc01@",
"alloc02@",
"alloc03@",
"alloc04@",
"alloc05@",
"alloc06@",
"alloc07@",
"alloc08@",
"alloc09@",
"alloc10-19@",
"alloc20-29@",
"alloc30-39@",
"alloc40-49@",
"alloc50-59@",
"alloc60-69@",
"alloc70-79@",
"alloc80-89@",
"alloc90-99@",
"alloc_large@",
};
uintnat caml_instr_alloc_jump = 0;
/* number of pointers followed to allocate from the free list */
#endif /*CAML_INSTR*/
/* [caml_fl_allocate] does not set the header of the newly allocated block.
The calling function must do it before any GC function gets called.
[caml_fl_allocate] returns a head pointer.
@ -160,6 +189,16 @@ header_t *caml_fl_allocate (mlsize_t wo_sz)
mlsize_t sz, prevsz;
Assert (sizeof (char *) == sizeof (value));
Assert (wo_sz >= 1);
#ifdef CAML_INSTR
if (wo_sz < 10){
++instr_size[wo_sz];
}else if (wo_sz < 100){
++instr_size[wo_sz/10 + 9];
}else{
++instr_size[19];
}
#endif /* CAML_INSTR */
switch (policy){
case Policy_next_fit:
Assert (fl_prev != Val_NULL);
@ -172,6 +211,9 @@ header_t *caml_fl_allocate (mlsize_t wo_sz)
}
prev = cur;
cur = Next (prev);
#ifdef CAML_INSTR
++ caml_instr_alloc_jump;
#endif
}
fl_last = prev;
/* Search from the start of the list to [fl_prev]. */
@ -183,6 +225,9 @@ header_t *caml_fl_allocate (mlsize_t wo_sz)
}
prev = cur;
cur = Next (prev);
#ifdef CAML_INSTR
++ caml_instr_alloc_jump;
#endif
}
/* No suitable block was found. */
return NULL;
@ -347,6 +392,13 @@ static header_t *last_fragment;
void caml_fl_init_merge (void)
{
#ifdef CAML_INSTR
int i;
for (i = 1; i < 20; i++){
CAML_INSTR_INT (instr_name[i], instr_size[i]);
instr_size[i] = 0;
}
#endif /* CAML_INSTR */
last_fragment = NULL;
caml_fl_merge = Fl_head;
#ifdef DEBUG

152
byterun/gc_ctrl.c
View File

@ -12,21 +12,26 @@
/***********************************************************************/
#include "caml/alloc.h"
#include "caml/backtrace.h"
#include "caml/compact.h"
#include "caml/custom.h"
#include "caml/fail.h"
#include "caml/finalise.h"
#include "caml/freelist.h"
#include "caml/gc.h"
#include "caml/gc_ctrl.h"
#include "caml/major_gc.h"
#include "caml/memory.h"
#include "caml/minor_gc.h"
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "caml/signals.h"
#ifdef NATIVE_CODE
#include "stack.h"
#else
#include "caml/stacks.h"
#endif
#include "caml/startup_aux.h"
#ifndef NATIVE_CODE
extern uintnat caml_max_stack_size; /* defined in stacks.c */
@ -214,7 +219,7 @@ static value heap_stats (int returnstats)
/* get a copy of these before allocating anything... */
double minwords = caml_stat_minor_words
+ (double) (caml_young_end - caml_young_ptr);
+ (double) (caml_young_alloc_end - caml_young_ptr);
double prowords = caml_stat_promoted_words;
double majwords = caml_stat_major_words + (double) caml_allocated_words;
intnat mincoll = caml_stat_minor_collections;
@ -255,8 +260,12 @@ void caml_heap_check (void)
CAMLprim value caml_gc_stat(value v)
{
value result;
CAML_INSTR_SETUP (tmr, "");
Assert (v == Val_unit);
return heap_stats (1);
result = heap_stats (1);
CAML_INSTR_TIME (tmr, "explicit/gc_stat");
return result;
}
CAMLprim value caml_gc_quick_stat(value v)
@ -266,7 +275,7 @@ CAMLprim value caml_gc_quick_stat(value v)
/* get a copy of these before allocating anything... */
double minwords = caml_stat_minor_words
+ (double) (caml_young_end - caml_young_ptr);
+ (double) (caml_young_alloc_end - caml_young_ptr);
double prowords = caml_stat_promoted_words;
double majwords = caml_stat_major_words + (double) caml_allocated_words;
intnat mincoll = caml_stat_minor_collections;
@ -303,7 +312,7 @@ CAMLprim value caml_gc_counters(value v)
/* get a copy of these before allocating anything... */
double minwords = caml_stat_minor_words
+ (double) (caml_young_end - caml_young_ptr);
+ (double) (caml_young_alloc_end - caml_young_ptr);
double prowords = caml_stat_promoted_words;
double majwords = caml_stat_major_words + (double) caml_allocated_words;
@ -314,12 +323,17 @@ CAMLprim value caml_gc_counters(value v)
CAMLreturn (res);
}
CAMLprim value caml_gc_huge_fallback_count (value v)
{
return Val_long (caml_huge_fallback_count);
}
CAMLprim value caml_gc_get(value v)
{
CAMLparam0 (); /* v is ignored */
CAMLlocal1 (res);
res = caml_alloc_tuple (7);
res = caml_alloc_tuple (8);
Store_field (res, 0, Val_long (caml_minor_heap_wsz)); /* s */
Store_field (res, 1, Val_long (caml_major_heap_increment)); /* i */
Store_field (res, 2, Val_long (caml_percent_free)); /* o */
@ -331,6 +345,7 @@ CAMLprim value caml_gc_get(value v)
Store_field (res, 5, Val_long (0));
#endif
Store_field (res, 6, Val_long (caml_allocation_policy)); /* a */
Store_field (res, 7, Val_long (caml_major_window)); /* w */
CAMLreturn (res);
}
@ -353,12 +368,20 @@ static intnat norm_minsize (intnat s)
return s;
}
static uintnat norm_window (intnat w)
{
if (w < 1) w = 1;
if (w > Max_major_window) w = Max_major_window;
return w;
}
CAMLprim value caml_gc_set(value v)
{
uintnat newpf, newpm;
asize_t newheapincr;
asize_t newminwsz;
uintnat oldpolicy;
CAML_INSTR_SETUP (tmr, "");
caml_verb_gc = Long_val (Field (v, 3));
@ -396,6 +419,16 @@ CAMLprim value caml_gc_set(value v)
caml_allocation_policy);
}
/* This field was added in 4.03.0. */
if (Wosize_val (v) >= 8){
int old_window = caml_major_window;
caml_set_major_window (norm_window (Long_val (Field (v, 7))));
if (old_window != caml_major_window){
caml_gc_message (0x20, "New smoothing window size: %d\n",
caml_major_window);
}
}
/* Minor heap size comes last because it will trigger a minor collection
(thus invalidating [v]) and it can raise [Out_of_memory]. */
newminwsz = norm_minsize (Long_val (Field (v, 0)));
@ -404,12 +437,17 @@ CAMLprim value caml_gc_set(value v)
newminwsz / 1024);
caml_set_minor_heap_size (Bsize_wsize (newminwsz));
}
CAML_INSTR_TIME (tmr, "explicit/gc_set");
return Val_unit;
}
CAMLprim value caml_gc_minor(value v)
{ Assert (v == Val_unit);
caml_minor_collection ();
{
CAML_INSTR_SETUP (tmr, "");
Assert (v == Val_unit);
caml_request_minor_gc ();
caml_gc_dispatch ();
CAML_INSTR_TIME (tmr, "explicit/gc_minor");
return Val_unit;
}
@ -429,17 +467,22 @@ static void test_and_compact (void)
}
CAMLprim value caml_gc_major(value v)
{ Assert (v == Val_unit);
{
CAML_INSTR_SETUP (tmr, "");
Assert (v == Val_unit);
caml_gc_message (0x1, "Major GC cycle requested\n", 0);
caml_empty_minor_heap ();
caml_finish_major_cycle ();
test_and_compact ();
caml_final_do_calls ();
CAML_INSTR_TIME (tmr, "explicit/gc_major");
return Val_unit;
}
CAMLprim value caml_gc_full_major(value v)
{ Assert (v == Val_unit);
{
CAML_INSTR_SETUP (tmr, "");
Assert (v == Val_unit);
caml_gc_message (0x1, "Full major GC cycle requested\n", 0);
caml_empty_minor_heap ();
caml_finish_major_cycle ();
@ -448,18 +491,24 @@ CAMLprim value caml_gc_full_major(value v)
caml_finish_major_cycle ();
test_and_compact ();
caml_final_do_calls ();
CAML_INSTR_TIME (tmr, "explicit/gc_full_major");
return Val_unit;
}
CAMLprim value caml_gc_major_slice (value v)
{
CAML_INSTR_SETUP (tmr, "");
Assert (Is_long (v));
caml_empty_minor_heap ();
return Val_long (caml_major_collection_slice (Long_val (v)));
caml_major_collection_slice (Long_val (v));
CAML_INSTR_TIME (tmr, "explicit/gc_major_slice");
return Val_long (0);
}
CAMLprim value caml_gc_compaction(value v)
{ Assert (v == Val_unit);
{
CAML_INSTR_SETUP (tmr, "");
Assert (v == Val_unit);
caml_gc_message (0x10, "Heap compaction requested\n", 0);
caml_empty_minor_heap ();
caml_finish_major_cycle ();
@ -468,9 +517,35 @@ CAMLprim value caml_gc_compaction(value v)
caml_finish_major_cycle ();
caml_compact_heap ();
caml_final_do_calls ();
CAML_INSTR_TIME (tmr, "explicit/gc_compact");
return Val_unit;
}
CAMLprim value caml_get_minor_free (value v)
{
return Val_int (caml_young_ptr - caml_young_alloc_start);
}
CAMLprim value caml_get_major_bucket (value v)
{
long i = Long_val (v);
if (i < 0) caml_invalid_argument ("Gc.get_bucket");
if (i < caml_major_window){
i += caml_major_ring_index;
if (i >= caml_major_window) i -= caml_major_window;
CAMLassert (0 <= i && i < caml_major_window);
return Val_long ((long) (caml_major_ring[i] * 1e6));
}else{
return Val_long (0);
}
}
CAMLprim value caml_get_major_credit (value v)
{
CAMLassert (v == Val_unit);
return Val_long ((long) (caml_major_work_credit * 1e6));
}
uintnat caml_normalize_heap_increment (uintnat i)
{
if (i < Bsize_wsize (Heap_chunk_min)){
@ -483,11 +558,15 @@ uintnat caml_normalize_heap_increment (uintnat i)
[major_incr] is either a percentage or a number of words */
void caml_init_gc (uintnat minor_size, uintnat major_size,
uintnat major_incr, uintnat percent_fr,
uintnat percent_m)
uintnat percent_m, uintnat window)
{
uintnat major_heap_size =
Bsize_wsize (caml_normalize_heap_increment (major_size));
CAML_INSTR_INIT ();
if (caml_init_alloc_for_heap () != 0){
caml_fatal_error ("cannot initialize heap: mmap failed\n");
}
if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)){
caml_fatal_error ("OCaml runtime error: cannot initialize page table\n");
}
@ -496,6 +575,7 @@ void caml_init_gc (uintnat minor_size, uintnat major_size,
caml_percent_free = norm_pfree (percent_fr);
caml_percent_max = norm_pmax (percent_m);
caml_init_major_heap (major_heap_size);
caml_major_window = norm_window (window);
caml_gc_message (0x20, "Initial minor heap size: %luk words\n",
caml_minor_heap_wsz / 1024);
caml_gc_message (0x20, "Initial major heap size: %luk bytes\n",
@ -511,6 +591,54 @@ void caml_init_gc (uintnat minor_size, uintnat major_size,
}
caml_gc_message (0x20, "Initial allocation policy: %d\n",
caml_allocation_policy);
caml_gc_message (0x20, "Initial smoothing window: %d\n",
caml_major_window);
}
/* FIXME After the startup_aux.c unification, move these functions there. */
CAMLprim value caml_runtime_variant (value unit)
{
CAMLassert (unit == Val_unit);
#if defined (DEBUG)
return caml_copy_string ("d");
#elif defined (CAML_INSTR)
return caml_copy_string ("i");
#elif defined (MMAP_INTERVAL)
return caml_copy_string ("m");
#else
return caml_copy_string ("");
#endif
}
extern int caml_parser_trace;
CAMLprim value caml_runtime_parameters (value unit)
{
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,
/* 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,
#else
/* l */ caml_max_stack_size,
#endif
/* o */ caml_percent_free,
/* O */ caml_percent_max,
/* p */ caml_parser_trace,
/* R */ /* missing */
/* s */ caml_minor_heap_wsz,
/* t */ caml_trace_level,
/* v */ caml_verb_gc,
/* w */ caml_major_window,
/* W */ caml_runtime_warnings
);
}
/* Control runtime warnings */

12
byterun/instrtrace.c
View File

@ -19,6 +19,7 @@
#include <string.h>
#include <ctype.h>
#include "caml/instrtrace.h"
#include "caml/instruct.h"
#include "caml/misc.h"
#include "caml/mlvalues.h"
@ -182,19 +183,21 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f)
if (prog && v % sizeof (int) == 0
&& (code_t) v >= prog
&& (code_t) v < (code_t) ((char *) prog + proglen))
fprintf (f, "=code@%ld", (code_t) v - prog);
fprintf (f, "=code@%" ARCH_INTNAT_PRINTF_FORMAT "d", (code_t) v - prog);
else if (Is_long (v))
fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v));
else if ((void*)v >= (void*)caml_stack_low
&& (void*)v < (void*)caml_stack_high)
fprintf (f, "=stack_%ld", (intnat*)caml_stack_high - (intnat*)v);
fprintf (f, "=stack_%" ARCH_INTNAT_PRINTF_FORMAT "d",
(intnat*)caml_stack_high - (intnat*)v);
else if (Is_block (v)) {
int s = Wosize_val (v);
int tg = Tag_val (v);
int l = 0;
switch (tg) {
case Closure_tag:
fprintf (f, "=closure[s%d,cod%ld]", s, (code_t) (Code_val (v)) - prog);
fprintf (f, "=closure[s%d,cod%" ARCH_INTNAT_PRINTF_FORMAT "d]",
s, (code_t) (Code_val (v)) - prog);
goto displayfields;
case String_tag:
l = caml_string_length (v);
@ -249,7 +252,8 @@ caml_trace_accu_sp_file (value accu, value * sp, code_t prog, int proglen,
value *p;
fprintf (f, "accu=");
caml_trace_value_file (accu, prog, proglen, f);
fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x @%ld:",
fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x "
"@%" ARCH_INTNAT_PRINTF_FORMAT "d:",
(intnat) sp, caml_stack_high - sp);
for (p = sp, i = 0; i < 12 + (1 << caml_trace_level) && p < caml_stack_high;
p++, i++) {

8
byterun/intern.c
View File

@ -19,6 +19,7 @@
#include <stdio.h>
#include "caml/alloc.h"
#include "caml/callback.h"
#include "caml/config.h"
#include "caml/custom.h"
#include "caml/fail.h"
#include "caml/gc.h"
@ -30,10 +31,6 @@
#include "caml/misc.h"
#include "caml/reverse.h"
#ifdef _MSC_VER
#define inline _inline
#endif
static unsigned char * intern_src;
/* Reading pointer in block holding input data. */
@ -618,8 +615,7 @@ static void intern_add_to_heap(mlsize_t whsize)
/* Add new heap chunk to heap if needed */
if (intern_extra_block != NULL) {
/* If heap chunk not filled totally, build free block at end */
asize_t request =
((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
asize_t request = Chunk_size (intern_extra_block);
header_t * end_extra_block =
(header_t *) intern_extra_block + Wsize_bsize(request);
Assert(intern_block == 0);

21
byterun/main.c
View File

@ -26,27 +26,6 @@ CAMLextern void caml_expand_command_line (int *, char ***);
int main(int argc, char **argv)
{
#ifdef DEBUG
caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0);
#if 0
{
int i;
char *ocp;
char *cp;
caml_gc_message (-1, "### command line:", 0);
for (i = 0; i < argc; i++){
caml_gc_message (-1, " %s", argv[i]);
}
caml_gc_message (-1, "\n", 0);
ocp = getenv ("OCAMLRUNPARAM");
caml_gc_message (-1, "### OCAMLRUNPARAM=%s\n", ocp == NULL ? "" : ocp);
cp = getenv ("CAMLRUNPARAM");
caml_gc_message (-1, "### CAMLRUNPARAM=%s\n", cp == NULL ? "" : cp);
caml_gc_message (-1, "### working dir: %s\n", getcwd (NULL, 0));
}
#endif
#endif
#ifdef _WIN32
/* Expand wildcards and diversions in command line */
caml_expand_command_line(&argc, &argv);

359
byterun/major_gc.c
View File

@ -12,6 +12,7 @@
/***********************************************************************/
#include <limits.h>
#include <math.h>
#include "caml/compact.h"
#include "caml/custom.h"
@ -33,6 +34,12 @@
#undef NATIVE_CODE_AND_NO_NAKED_POINTERS
#endif
#ifdef _MSC_VER
static inline double fmin(double a, double b) {
return (a < b) ? a : b;
}
#endif
uintnat caml_percent_free;
uintnat caml_major_heap_increment;
CAMLexport char *caml_heap_start;
@ -55,6 +62,12 @@ static char *markhp, *chunk, *limit;
int caml_gc_subphase; /* Subphase_{main,weak1,weak2,final} */
static value *weak_prev;
int caml_major_window = 1;
double caml_major_ring[Max_major_window] = { 0. };
int caml_major_ring_index = 0;
double caml_major_work_credit = 0.0;
double caml_gc_clock = 0.0;
#ifdef DEBUG
static unsigned long major_gc_counter = 0;
#endif
@ -91,7 +104,7 @@ static void realloc_gray_vals (void)
void caml_darken (value v, value *p /* not used */)
{
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
if (Is_block (v) && Wosize_val (v) > 0) {
if (Is_block (v) && !Is_young (v) && Wosize_val (v) > 0) {
#else
if (Is_block (v) && Is_in_heap (v)) {
#endif
@ -129,9 +142,9 @@ static void start_cycle (void)
Assert (caml_gc_phase == Phase_idle);
Assert (gray_vals_cur == gray_vals);
caml_gc_message (0x01, "Starting new major GC cycle\n", 0);
caml_darken_all_roots();
caml_darken_all_roots_start ();
caml_gc_phase = Phase_mark;
caml_gc_subphase = Subphase_main;
caml_gc_subphase = Subphase_roots;
markhp = NULL;
#ifdef DEBUG
++ major_gc_counter;
@ -139,35 +152,65 @@ static void start_cycle (void)
#endif
}
/* We may stop the slice inside values, in order to avoid large latencies
on large arrays. In this case, [current_value] is the partially-marked
value and [current_index] is the index of the next field to be marked.
*/
static value current_value = 0;
static mlsize_t current_index = 0;
#ifdef CAML_INSTR
#define INSTR(x) x
#else
#define INSTR(x) /**/
#endif
static void mark_slice (intnat work)
{
value *gray_vals_ptr; /* Local copy of gray_vals_cur */
value *gray_vals_ptr; /* Local copy of [gray_vals_cur] */
value v, child;
header_t hd;
mlsize_t size, i;
header_t hd, chd;
mlsize_t size, i, start, end; /* [start] is a local copy of [current_index] */
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
int marking_closure = 0;
#endif
#ifdef CAML_INSTR
int slice_fields = 0;
int slice_pointers = 0;
#endif
caml_gc_message (0x40, "Marking %ld words\n", work);
caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase);
gray_vals_ptr = gray_vals_cur;
v = current_value;
start = current_index;
while (work > 0){
if (gray_vals_ptr > gray_vals){
if (v == 0 && gray_vals_ptr > gray_vals){
CAMLassert (start == 0);
v = *--gray_vals_ptr;
CAMLassert (Is_gray_val (v));
}
if (v != 0){
hd = Hd_val(v);
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
marking_closure =
(Tag_hd (hd) == Closure_tag || Tag_hd (hd) == Infix_tag);
#endif
Assert (Is_gray_hd (hd));
Hd_val (v) = Blackhd_hd (hd);
size = Wosize_hd (hd);
end = start + work;
if (Tag_hd (hd) < No_scan_tag){
for (i = 0; i < size; i++){
start = size < start ? size : start;
end = size < end ? size : end;
CAMLassert (end > start);
INSTR (slice_fields += end - start;)
INSTR (if (size > end)
CAML_INSTR_INT ("major/mark/slice/remain", size - end);)
for (i = start; i < end; i++){
child = Field (v, i);
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
if (Is_block (child)
&& ! Is_young (child)
&& Wosize_val (child) > 0 /* Atoms never need to be marked. */
/* Closure blocks contain code pointers at offsets that cannot
be reliably determined, so we always use the page table when
@ -176,8 +219,9 @@ static void mark_slice (intnat work)
#else
if (Is_block (child) && Is_in_heap (child)) {
#endif
hd = Hd_val (child);
if (Tag_hd (hd) == Forward_tag){
INSTR (++ slice_pointers;)
chd = Hd_val (child);
if (Tag_hd (chd) == Forward_tag){
value f = Forward_val (child);
if (Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
@ -185,18 +229,19 @@ static void mark_slice (intnat work)
/* Do not short-circuit the pointer. */
}else{
Field (v, i) = f;
if (Is_block (f) && Is_young (f) && !Is_young (child))
add_to_ref_table (&caml_ref_table, &Field (v, i));
}
}
else if (Tag_hd(hd) == Infix_tag) {
}else if (Tag_hd(chd) == Infix_tag) {
child -= Infix_offset_val(child);
hd = Hd_val(child);
chd = Hd_val(child);
}
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
/* See [caml_darken] for a description of this assertion. */
CAMLassert (Is_in_heap (child) || Is_black_hd (hd));
CAMLassert (Is_in_heap (child) || Is_black_hd (chd));
#endif
if (Is_white_hd (hd)){
Hd_val (child) = Grayhd_hd (hd);
if (Is_white_hd (chd)){
Hd_val (child) = Grayhd_hd (chd);
*gray_vals_ptr++ = child;
if (gray_vals_ptr >= gray_vals_end) {
gray_vals_cur = gray_vals_ptr;
@ -206,8 +251,25 @@ static void mark_slice (intnat work)
}
}
}
if (end < size){
work = 0;
start = end;
/* [v] doesn't change. */
CAMLassert (Is_gray_val (v));
}else{
CAMLassert (end == size);
Hd_val (v) = Blackhd_hd (hd);
work -= Whsize_wosize(end - start);
start = 0;
v = 0;
}
}else{
/* The block doesn't contain any pointers. */
CAMLassert (start == 0);
Hd_val (v) = Blackhd_hd (hd);
work -= Whsize_wosize(size);
v = 0;
}
work -= Whsize_wosize(size);
}else if (markhp != NULL){
if (markhp == limit){
chunk = Chunk_next (chunk);
@ -220,7 +282,8 @@ static void mark_slice (intnat work)
}else{
if (Is_gray_val (Val_hp (markhp))){
Assert (gray_vals_ptr == gray_vals);
*gray_vals_ptr++ = Val_hp (markhp);
CAMLassert (v == 0 && start == 0);
v = Val_hp (markhp);
}
markhp += Bhsize_hp (markhp);
}
@ -231,6 +294,15 @@ static void mark_slice (intnat work)
limit = chunk + Chunk_size (chunk);
}else{
switch (caml_gc_subphase){
case Subphase_roots: {
gray_vals_cur = gray_vals_ptr;
work = caml_darken_all_roots_slice (work);
gray_vals_ptr = gray_vals_cur;
if (work > 0){
caml_gc_subphase = Subphase_main;
}
}
break;
case Subphase_main: {
/* The main marking phase is over. Start removing weak pointers to
dead values. */
@ -251,7 +323,7 @@ static void mark_slice (intnat work)
curfield = Field (cur, i);
weak_again:
if (curfield != caml_weak_none
&& Is_block (curfield) && Is_in_heap (curfield)){
&& Is_block (curfield) && Is_in_heap_or_young (curfield)){
if (Tag_val (curfield) == Forward_tag){
value f = Forward_val (curfield);
if (Is_block (f)) {
@ -260,11 +332,13 @@ static void mark_slice (intnat work)
/* Do not short-circuit the pointer. */
}else{
Field (cur, i) = curfield = f;
if (Is_block (f) && Is_young (f))
add_to_ref_table (&caml_weak_ref_table, &Field (cur, i));
goto weak_again;
}
}
}
if (Is_white_val (curfield)){
if (Is_white_val (curfield) && !Is_young (curfield)){
Field (cur, i) = caml_weak_none;
}
}
@ -277,6 +351,10 @@ static void mark_slice (intnat work)
gray_vals_cur = gray_vals_ptr;
caml_final_update ();
gray_vals_ptr = gray_vals_cur;
if (gray_vals_ptr > gray_vals){
v = *--gray_vals_ptr;
CAMLassert (start == 0);
}
caml_gc_subphase = Subphase_weak2;
weak_prev = &caml_weak_list_head;
}
@ -304,7 +382,6 @@ static void mark_slice (intnat work)
break;
case Subphase_final: {
/* Initialise the sweep phase. */
gray_vals_cur = gray_vals_ptr;
caml_gc_sweep_hp = caml_heap_start;
caml_fl_init_merge ();
caml_gc_phase = Phase_sweep;
@ -321,6 +398,10 @@ static void mark_slice (intnat work)
}
}
gray_vals_cur = gray_vals_ptr;
current_value = v;
current_index = start;
INSTR (CAML_INSTR_INT ("major/mark/slice/fields#", slice_fields);)
INSTR (CAML_INSTR_INT ("major/mark/slice/pointers#", slice_pointers);)
}
static void sweep_slice (intnat work)
@ -368,14 +449,37 @@ static void sweep_slice (intnat work)
}
}
/* The main entry point for the GC. Called after each minor GC.
[howmuch] is the amount of work to do, 0 to let the GC compute it.
Return the computed amount of work to do.
#ifdef CAML_INSTR
static char *mark_slice_name[] = {
/* 0 */ NULL,
/* 1 */ NULL,
/* 2 */ NULL,
/* 3 */ NULL,
/* 4 */ NULL,
/* 5 */ NULL,
/* 6 */ NULL,
/* 7 */ NULL,
/* 8 */ NULL,
/* 9 */ NULL,
/* 10 */ "major/mark_roots",
/* 11 */ "major/mark_main",
/* 12 */ "major/mark_weak1",
/* 13 */ "major/mark_weak2",
/* 14 */ "major/mark_final",
};
#endif
/* The main entry point for the major GC. Called about once for each
minor GC. [howmuch] is the amount of work to do:
-1 if the GC is triggered automatically
0 to let the GC compute the amount of work
[n] to make the GC do enough work to (on average) free [n] words
*/
intnat caml_major_collection_slice (intnat howmuch)
void caml_major_collection_slice (intnat howmuch)
{
double p, dp;
double p, dp, filt_p, spend;
intnat computed_work;
int i;
/*
Free memory at the start of the GC cycle (garbage + free list) (assumed):
FM = caml_stat_heap_wsz * caml_percent_free
@ -395,24 +499,37 @@ intnat caml_major_collection_slice (intnat howmuch)
PE = caml_extra_heap_resources
Proportion of total work to do in this slice:
P = max (PH, PE)
Here, we insert a time-based filter on the P variable to avoid large
latency spikes in the GC, so the P below is a smoothed-out version of
the P above.
Amount of marking work for the GC cycle:
MW = caml_stat_heap_wsz * 100 / (100 + caml_percent_free)
+ caml_incremental_roots_count
Amount of sweeping work for the GC cycle:
SW = caml_stat_heap_wsz
In order to finish marking with a non-empty free list, we will
use 40% of the time for marking, and 60% for sweeping.
If TW is the total work for this cycle,
MW = 40/100 * TW
SW = 60/100 * TW
Let MT be the time spent marking, ST the time spent sweeping, and TT
the total time for this cycle. We have:
MT = 40/100 * TT
ST = 60/100 * TT
Amount of work to do for this slice:
W = P * TW
Amount of time to spend on this slice:
T = P * TT = P * MT / (40/100) = P * ST / (60/100)
Since we must do MW work in MT time or SW work in ST time, the amount
of work for this slice is:
MS = P * MW / (40/100) if marking
SS = P * SW / (60/100) if sweeping
Amount of marking work for a marking slice:
MS = P * MW / (40/100)
MS = P * caml_stat_heap_wsz * 250 / (100 + caml_percent_free)
MS = P * (caml_stat_heap_wsz * 250 / (100 + caml_percent_free)
+ 2.5 * caml_incremental_roots_count)
Amount of sweeping work for a sweeping slice:
SS = P * SW / (60/100)
SS = P * caml_stat_heap_wsz * 5 / 3
@ -421,8 +538,7 @@ intnat caml_major_collection_slice (intnat howmuch)
*/
if (caml_major_slice_begin_hook != NULL) (*caml_major_slice_begin_hook) ();
if (caml_gc_phase == Phase_idle) start_cycle ();
CAML_INSTR_SETUP (tmr, "major");
p = (double) caml_allocated_words * 3.0 * (100 + caml_percent_free)
/ caml_stat_heap_wsz / caml_percent_free / 2.0;
@ -434,51 +550,133 @@ intnat caml_major_collection_slice (intnat howmuch)
}
if (p < dp) p = dp;
if (p < caml_extra_heap_resources) p = caml_extra_heap_resources;
if (p > 0.3) p = 0.3;
CAML_INSTR_INT ("major/work/extra#",
(uintnat) (caml_extra_heap_resources * 1000000));
caml_gc_message (0x40, "ordered work = %ld words\n", howmuch);
caml_gc_message (0x40, "allocated_words = %"
ARCH_INTNAT_PRINTF_FORMAT "u\n",
caml_allocated_words);
caml_gc_message (0x40, "extra_heap_resources = %"
ARCH_INTNAT_PRINTF_FORMAT "uu\n",
(uintnat) (caml_extra_heap_resources * 1000000));
caml_gc_message (0x40, "amount of work to do = %"
ARCH_INTNAT_PRINTF_FORMAT "uu\n",
(uintnat) (p * 1000000));
caml_gc_message (0x40, "raw work-to-do = %"
ARCH_INTNAT_PRINTF_FORMAT "du\n",
(intnat) (p * 1000000));
for (i = 0; i < caml_major_window; i++){
caml_major_ring[i] += p / caml_major_window;
}
if (caml_gc_clock >= 1.0){
caml_gc_clock -= 1.0;
++caml_major_ring_index;
if (caml_major_ring_index >= caml_major_window){
caml_major_ring_index = 0;
}
}
if (howmuch == -1){
/* auto-triggered GC slice: spend work credit on the current bucket,
then do the remaining work, if any */
/* Note that the minor GC guarantees that the major slice is called in
automatic mode (with [howmuch] = -1) at least once per clock tick.
This means we never leave a non-empty bucket behind. */
spend = fmin (caml_major_work_credit,
caml_major_ring[caml_major_ring_index]);
caml_major_work_credit -= spend;
filt_p = caml_major_ring[caml_major_ring_index] - spend;
caml_major_ring[caml_major_ring_index] = 0.0;
}else{
/* forced GC slice: do work and add it to the credit */
if (howmuch == 0){
/* automatic setting: size of next bucket
we do not use the current bucket, as it may be empty */
int i = caml_major_ring_index + 1;
if (i >= caml_major_window) i = 0;
filt_p = caml_major_ring[i];
}else{
/* manual setting */
filt_p = (double) howmuch * 3.0 * (100 + caml_percent_free)
/ caml_stat_heap_wsz / caml_percent_free / 2.0;
}
caml_major_work_credit += filt_p;
}
p = filt_p;
caml_gc_message (0x40, "filtered work-to-do = %"
ARCH_INTNAT_PRINTF_FORMAT "du\n",
(intnat) (p * 1000000));
if (caml_gc_phase == Phase_idle){
if (caml_young_ptr == caml_young_alloc_end){
/* We can only start a major GC cycle if the minor allocation arena
is empty, otherwise we'd have to treat it as a set of roots. */
start_cycle ();
CAML_INSTR_TIME (tmr, "major/roots");
}
p = 0;
goto finished;
}
if (p < 0){
p = 0;
goto finished;
}
if (caml_gc_phase == Phase_mark){
computed_work = (intnat) (p * caml_stat_heap_wsz * 250
/ (100 + caml_percent_free));
computed_work = (intnat) (p * (caml_stat_heap_wsz * 250
/ (100 + caml_percent_free)
+ caml_incremental_roots_count));
}else{
computed_work = (intnat) (p * caml_stat_heap_wsz * 5 / 3);
}
caml_gc_message (0x40, "ordered work = %ld words\n", howmuch);
caml_gc_message (0x40, "computed work = %ld words\n", computed_work);
if (howmuch == 0) howmuch = computed_work;
if (caml_gc_phase == Phase_mark){
mark_slice (howmuch);
CAML_INSTR_INT ("major/work/mark#", computed_work);
mark_slice (computed_work);
CAML_INSTR_TIME (tmr, mark_slice_name[caml_gc_subphase]);
caml_gc_message (0x02, "!", 0);
}else{
Assert (caml_gc_phase == Phase_sweep);
sweep_slice (howmuch);
CAML_INSTR_INT ("major/work/sweep#", computed_work);
sweep_slice (computed_work);
CAML_INSTR_TIME (tmr, "major/sweep");
caml_gc_message (0x02, "$", 0);
}
if (caml_gc_phase == Phase_idle) caml_compact_heap_maybe ();
if (caml_gc_phase == Phase_idle){
caml_compact_heap_maybe ();
CAML_INSTR_TIME (tmr, "major/check_and_compact");
}
finished:
caml_gc_message (0x40, "work-done = %"
ARCH_INTNAT_PRINTF_FORMAT "du\n",
(intnat) (p * 1000000));
/* if some of the work was not done, take it back from the credit
or spread it over the buckets. */
p = filt_p - p;
spend = fmin (p, caml_major_work_credit);
caml_major_work_credit -= spend;
if (p > spend){
p -= spend;
p /= caml_major_window;
for (i = 0; i < caml_major_window; i++) caml_major_ring[i] += p;
}
caml_stat_major_words += caml_allocated_words;
caml_allocated_words = 0;
caml_dependent_allocated = 0;
caml_extra_heap_resources = 0.0;
if (caml_major_slice_end_hook != NULL) (*caml_major_slice_end_hook) ();
return computed_work;
}
/* The minor heap must be empty when this function is called;
the minor heap is empty when this function returns.
*/
/* This does not call caml_compact_heap_maybe because the estimations of
/* This does not call [caml_compact_heap_maybe] because the estimates of
free and live memory are only valid for a cycle done incrementally.
Besides, this function is called by caml_compact_heap_maybe.
Besides, this function itself is called by [caml_compact_heap_maybe].
*/
void caml_finish_major_cycle (void)
{
@ -491,27 +689,12 @@ void caml_finish_major_cycle (void)
caml_allocated_words = 0;
}
/* Make sure the request is at least Heap_chunk_min and round it up
to a multiple of the page size.
The argument and result are both numbers of words.
/* Call this function to make sure [bsz] is greater than or equal
to both [Heap_chunk_min] and the current heap increment.
*/
static asize_t clip_heap_chunk_size (asize_t request)
asize_t caml_clip_heap_chunk_wsz (asize_t wsz)
{
if (request < Heap_chunk_min){
request = Heap_chunk_min;
}
return
Wsize_bsize (((Bsize_wsize (request) + Page_size - 1)
>> Page_log) << Page_log);
}
/* Compute the heap increment, make sure the request is at least that big,
then call clip_heap_chunk_size, then make sure the result is >= request.
The argument and result are both numbers of words.
*/
asize_t caml_round_heap_chunk_wsz (asize_t request)
{
asize_t result = request;
asize_t result = wsz;
uintnat incr;
/* Compute the heap increment as a word size. */
@ -524,11 +707,8 @@ asize_t caml_round_heap_chunk_wsz (asize_t request)
if (result < incr){
result = incr;
}
result = clip_heap_chunk_size (result);
if (result < request){
caml_raise_out_of_memory ();
return 0; /* not reached */
if (result < Heap_chunk_min){
result = Heap_chunk_min;
}
return result;
}
@ -536,21 +716,25 @@ asize_t caml_round_heap_chunk_wsz (asize_t request)
/* [heap_size] is a number of bytes */
void caml_init_major_heap (asize_t heap_size)
{
caml_stat_heap_wsz = Wsize_bsize (clip_heap_chunk_size (heap_size));
int i;
caml_stat_heap_wsz = caml_clip_heap_chunk_wsz (Wsize_bsize (heap_size));
caml_stat_top_heap_wsz = caml_stat_heap_wsz;
Assert (Bsize_wsize (caml_stat_heap_wsz) % Page_size == 0);
caml_heap_start =
(char *) caml_alloc_for_heap (Bsize_wsize (caml_stat_heap_wsz));
if (caml_heap_start == NULL)
caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n");
caml_fatal_error ("Fatal error: cannot allocate initial major heap.\n");
Chunk_next (caml_heap_start) = NULL;
caml_stat_heap_wsz = Wsize_bsize (Chunk_size (caml_heap_start));
caml_stat_heap_chunks = 1;
caml_stat_top_heap_wsz = caml_stat_heap_wsz;
if (caml_page_table_add(In_heap, caml_heap_start,
caml_heap_start + Bsize_wsize (caml_stat_heap_wsz))
!= 0) {
caml_fatal_error ("Fatal error: not enough memory "
"for the initial page table.\n");
caml_fatal_error ("Fatal error: cannot allocate "
"initial page table.\n");
}
caml_fl_init_merge ();
@ -566,4 +750,21 @@ void caml_init_major_heap (asize_t heap_size)
heap_is_pure = 1;
caml_allocated_words = 0;
caml_extra_heap_resources = 0.0;
for (i = 0; i < Max_major_window; i++) caml_major_ring[i] = 0.0;
}
void caml_set_major_window (int w){
uintnat total = 0;
int i;
if (w == caml_major_window) return;
CAMLassert (w <= Max_major_window);
/* Collect the current work-to-do from the buckets. */
for (i = 0; i < caml_major_window; i++){
total += caml_major_ring[i];
}
/* Redistribute to the new buckets. */
for (i = 0; i < w; i++){
caml_major_ring[i] = total / w;
}
caml_major_window = w;
}

114
byterun/memory.c
View File

@ -14,6 +14,7 @@
#include <stdlib.h>
#include <string.h>
#include "caml/address_class.h"
#include "caml/config.h"
#include "caml/fail.h"
#include "caml/freelist.h"
#include "caml/gc.h"
@ -26,9 +27,17 @@
#include "caml/mlvalues.h"
#include "caml/signals.h"
#ifdef _MSC_VER
#define inline _inline
#endif
int caml_huge_fallback_count = 0;
/* Number of times that mmapping big pages fails and we fell back to small
pages. This counter is available to the program through
[Gc.huge_fallback_count].
*/
uintnat caml_use_huge_pages = 0;
/* True iff the program allocates heap chunks by mmapping huge pages.
This is set when parsing [OCAMLRUNPARAM] and must stay constant
after that.
*/
extern uintnat caml_percent_free; /* major_gc.c */
@ -221,25 +230,56 @@ int caml_page_table_remove(int kind, void * start, void * end)
return 0;
}
/* Initialize the [alloc_for_heap] system.
This function must be called exactly once, and it must be called
before the first call to [alloc_for_heap].
It returns 0 on success and -1 on failure.
*/
int caml_init_alloc_for_heap (void)
{
return 0;
}
/* Allocate a block of the requested size, to be passed to
[caml_add_to_heap] later.
[request] must be a multiple of [Page_size], it is a number of bytes.
[caml_alloc_for_heap] returns NULL if the request cannot be satisfied.
The returned pointer is a hp, but the header must be initialized by
the caller.
[request] will be rounded up to some implementation-dependent size.
The caller must use [Chunk_size] on the result to recover the actual
size.
Return NULL if the request cannot be satisfied. The returned pointer
is a hp, but the header (and the contents) must be initialized by the
caller.
*/
char *caml_alloc_for_heap (asize_t request)
{
char *mem;
void *block;
Assert (request % Page_size == 0);
mem = caml_aligned_malloc (request + sizeof (heap_chunk_head),
sizeof (heap_chunk_head), &block);
if (mem == NULL) return NULL;
mem += sizeof (heap_chunk_head);
Chunk_size (mem) = request;
Chunk_block (mem) = block;
return mem;
if (caml_use_huge_pages){
#ifdef HAS_HUGE_PAGES
uintnat size = Round_mmap_size (sizeof (heap_chunk_head) + request);
void *block;
char *mem;
block = mmap (NULL, size, PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANONYMOUS | MAP_HUGETLB, -1, 0);
if (block == MAP_FAILED) return NULL;
mem = (char *) block + sizeof (heap_chunk_head);
Chunk_size (mem) = size - sizeof (heap_chunk_head);
Chunk_block (mem) = block;
return mem;
#else
return NULL;
#endif
}else{
char *mem;
void *block;
request = ((request + Page_size - 1) >> Page_log) << Page_log;
mem = caml_aligned_malloc (request + sizeof (heap_chunk_head),
sizeof (heap_chunk_head), &block);
if (mem == NULL) return NULL;
mem += sizeof (heap_chunk_head);
Chunk_size (mem) = request;
Chunk_block (mem) = block;
return mem;
}
}
/* Use this function to free a block allocated with [caml_alloc_for_heap]
@ -247,7 +287,15 @@ char *caml_alloc_for_heap (asize_t request)
*/
void caml_free_for_heap (char *mem)
{
free (Chunk_block (mem));
if (caml_use_huge_pages){
#ifdef HAS_HUGE_PAGES
munmap (Chunk_block (mem), Chunk_size (mem) + sizeof (heap_chunk_head));
#else
CAMLassert (0);
#endif
}else{
free (Chunk_block (mem));
}
}
/* Take a chunk of memory as argument, which must be the result of a
@ -263,10 +311,9 @@ void caml_free_for_heap (char *mem)
*/
int caml_add_to_heap (char *m)
{
Assert (Chunk_size (m) % Page_size == 0);
#ifdef DEBUG
/* Should check the contents of the block. */
#endif /* debug */
#endif /* DEBUG */
caml_gc_message (0x04, "Growing heap to %luk bytes\n",
(Bsize_wsize (caml_stat_heap_wsz) + Chunk_size (m)) / 1024);
@ -314,14 +361,14 @@ static value *expand_heap (mlsize_t request)
asize_t over_request, malloc_request, remain;
Assert (request <= Max_wosize);
over_request = Whsize_wosize (request + request / 100 * caml_percent_free);
malloc_request = caml_round_heap_chunk_wsz (over_request);
over_request = request + request / 100 * caml_percent_free;
malloc_request = caml_clip_heap_chunk_wsz (over_request);
mem = (value *) caml_alloc_for_heap (Bsize_wsize (malloc_request));
if (mem == NULL){
caml_gc_message (0x04, "No room for growing heap\n", 0);
return NULL;
}
remain = malloc_request;
remain = Wsize_bsize (Chunk_size (mem));
prev = hp = mem;
/* FIXME find a way to do this with a call to caml_make_free_blocks */
while (Wosize_whsize (remain) > Max_wosize){
@ -451,7 +498,8 @@ static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag,
Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp)));
caml_allocated_words += Whsize_wosize (wosize);
if (caml_allocated_words > caml_minor_heap_wsz){
caml_urge_major_slice ();
CAML_INSTR_INT ("request_major/alloc_shr@", 1);
caml_request_major_slice ();
}
#ifdef DEBUG
{
@ -512,13 +560,15 @@ CAMLexport void caml_adjust_gc_speed (mlsize_t res, mlsize_t max)
if (res > max) res = max;
caml_extra_heap_resources += (double) res / (double) max;
if (caml_extra_heap_resources > 1.0){
CAML_INSTR_INT ("request_major/adjust_gc_speed_1@", 1);
caml_extra_heap_resources = 1.0;
caml_urge_major_slice ();
caml_request_major_slice ();
}
if (caml_extra_heap_resources
> (double) caml_minor_heap_wsz / 2.0
/ (double) caml_stat_heap_wsz) {
caml_urge_major_slice ();
CAML_INSTR_INT ("request_major/adjust_gc_speed_2@", 1);
caml_request_major_slice ();
}
}
@ -535,10 +585,7 @@ CAMLexport CAMLweakdef void caml_initialize (value *fp, value val)
CAMLassert(Is_in_heap(fp));
*fp = val;
if (Is_block (val) && Is_young (val)) {
if (caml_ref_table.ptr >= caml_ref_table.limit){
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = fp;
add_to_ref_table (&caml_ref_table, fp);
}
}
@ -586,12 +633,7 @@ CAMLexport CAMLweakdef void caml_modify (value *fp, value val)
}
/* Check for condition 1. */
if (Is_block(val) && Is_young(val)) {
/* Add [fp] to remembered set */
if (caml_ref_table.ptr >= caml_ref_table.limit){
CAMLassert (caml_ref_table.ptr == caml_ref_table.limit);
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = fp;
add_to_ref_table (&caml_ref_table, fp);
}
}
}

201
byterun/minor_gc.c
View File

@ -27,10 +27,36 @@
#include "caml/signals.h"
#include "caml/weak.h"
/* Pointers into the minor heap.
[caml_young_base]
The [malloc] block that contains the heap.
[caml_young_start] ... [caml_young_end]
The whole range of the minor heap: all young blocks are inside
this interval.
[caml_young_alloc_start]...[caml_young_alloc_end]
The allocation arena: newly-allocated blocks are carved from
this interval.
[caml_young_alloc_mid] is the mid-point of this interval.
[caml_young_ptr], [caml_young_trigger], [caml_young_limit]
These pointers are all inside the allocation arena.
- [caml_young_ptr] is where the next allocation will take place.
- [caml_young_trigger] is how far we can allocate before triggering
[caml_gc_dispatch]. Currently, it is either [caml_young_alloc_start]
or the mid-point of the allocation arena.
- [caml_young_limit] is the pointer that is compared to
[caml_young_ptr] for allocation. It is either
[caml_young_alloc_end] if a signal is pending and we are in
native code, or [caml_young_trigger].
*/
asize_t caml_minor_heap_wsz;
static void *caml_young_base = NULL;
CAMLexport value *caml_young_start = NULL, *caml_young_end = NULL;
CAMLexport value *caml_young_alloc_start = NULL,
*caml_young_alloc_mid = NULL,
*caml_young_alloc_end = NULL;
CAMLexport value *caml_young_ptr = NULL, *caml_young_limit = NULL;
CAMLexport value *caml_young_trigger = NULL;
CAMLexport struct caml_ref_table
caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0},
@ -40,10 +66,6 @@ CAMLexport struct caml_ref_table
int caml_in_minor_collection = 0;
#ifdef DEBUG
static unsigned long minor_gc_counter = 0;
#endif
/* [sz] and [rsv] are numbers of entries */
void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv)
{
@ -75,32 +97,73 @@ static void clear_table (struct caml_ref_table *tbl)
tbl->limit = tbl->threshold;
}
/* [size] is a number of bytes */
void caml_set_minor_heap_size (asize_t size)
void caml_set_minor_heap_size (asize_t bsz)
{
char *new_heap;
void *new_heap_base;
Assert (size >= Bsize_wsize(Minor_heap_min));
Assert (size <= Bsize_wsize(Minor_heap_max));
Assert (size % sizeof (value) == 0);
if (caml_young_ptr != caml_young_end) caml_minor_collection ();
Assert (caml_young_ptr == caml_young_end);
new_heap = caml_aligned_malloc(size, 0, &new_heap_base);
Assert (bsz >= Bsize_wsize(Minor_heap_min));
Assert (bsz <= Bsize_wsize(Minor_heap_max));
Assert (bsz % sizeof (value) == 0);
if (caml_young_ptr != caml_young_alloc_end){
CAML_INSTR_INT ("force_minor/set_minor_heap_size@", 1);
caml_requested_minor_gc = 0;
caml_young_trigger = caml_young_alloc_mid;
caml_young_limit = caml_young_trigger;
caml_empty_minor_heap ();
}
CAMLassert (caml_young_ptr == caml_young_alloc_end);
#ifdef MMAP_INTERVAL
{
static uintnat minor_heap_mapped_bsz = 0;
uintnat new_mapped_bsz;
new_mapped_bsz = Round_mmap_size (bsz);
void *block;
CAMLassert (caml_young_start != NULL);
if (new_mapped_bsz > minor_heap_mapped_bsz){
uintnat addbsz = new_mapped_bsz - minor_heap_mapped_bsz;
new_heap = (char *) caml_young_start - addbsz;
block = caml_mmap_heap (new_heap, addbsz, PROT_READ | PROT_WRITE,
MAP_FIXED);
if (block != new_heap){
if (minor_heap_mapped_bsz == 0){
caml_fatal_error ("cannot initialize minor heap: mmap failed\n");
}else{
caml_raise_out_of_memory ();
}
}
new_heap_base = new_heap;
}else if (new_mapped_bsz < minor_heap_mapped_bsz){
uintnat subbsz = minor_heap_mapped_bsz - new_mapped_bsz;
(void) caml_mmap_heap (caml_young_start, subbsz, PROT_NONE,
MAP_FIXED | MAP_NORESERVE);
new_heap_base = new_heap = (char *) caml_young_start + subbsz;
}else{
new_heap_base = new_heap = caml_young_base;
}
}
#else
new_heap = caml_aligned_malloc(bsz, 0, &new_heap_base);
if (new_heap == NULL) caml_raise_out_of_memory();
if (caml_page_table_add(In_young, new_heap, new_heap + size) != 0)
if (caml_page_table_add(In_young, new_heap, new_heap + bsz) != 0)
caml_raise_out_of_memory();
if (caml_young_start != NULL){
caml_page_table_remove(In_young, caml_young_start, caml_young_end);
free (caml_young_base);
}
#endif
caml_young_base = new_heap_base;
caml_young_start = (value *) new_heap;
caml_young_end = (value *) (new_heap + size);
caml_young_limit = caml_young_start;
caml_young_ptr = caml_young_end;
caml_minor_heap_wsz = Wsize_bsize (size);
caml_young_end = (value *) (new_heap + bsz);
caml_young_alloc_start = caml_young_start;
caml_young_alloc_mid = caml_young_alloc_start + Wsize_bsize (bsz) / 2;
caml_young_alloc_end = caml_young_end;
caml_young_trigger = caml_young_alloc_start;
caml_young_limit = caml_young_trigger;
caml_young_ptr = caml_young_alloc_end;
caml_minor_heap_wsz = Wsize_bsize (bsz);
reset_table (&caml_ref_table);
reset_table (&caml_weak_ref_table);
@ -232,16 +295,20 @@ void caml_empty_minor_heap (void)
value **r;
uintnat prev_alloc_words;
if (caml_young_ptr != caml_young_end){
if (caml_young_ptr != caml_young_alloc_end){
if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) ();
CAML_INSTR_SETUP (tmr, "minor");
prev_alloc_words = caml_allocated_words;
caml_in_minor_collection = 1;
caml_gc_message (0x02, "<", 0);
caml_oldify_local_roots();
CAML_INSTR_TIME (tmr, "minor/local_roots");
for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){
caml_oldify_one (**r, *r);
}
CAML_INSTR_TIME (tmr, "minor/ref_table");
caml_oldify_mopup ();
CAML_INSTR_TIME (tmr, "minor/copy");
for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){
if (Is_block (**r) && Is_young (**r)){
if (Hd_val (**r) == 0){
@ -258,18 +325,22 @@ void caml_empty_minor_heap (void)
final_fun((value)*r);
}
}
if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start;
caml_stat_minor_words += caml_young_end - caml_young_ptr;
caml_young_ptr = caml_young_end;
caml_young_limit = caml_young_start;
CAML_INSTR_TIME (tmr, "minor/update_weak");
CAMLassert (caml_young_ptr >= caml_young_alloc_start);
caml_stat_minor_words += caml_young_alloc_end - caml_young_ptr;
caml_gc_clock += (double) (caml_young_alloc_end - caml_young_ptr)
/ caml_minor_heap_wsz;
caml_young_ptr = caml_young_alloc_end;
clear_table (&caml_ref_table);
clear_table (&caml_weak_ref_table);
clear_table (&caml_finalize_table);
caml_gc_message (0x02, ">", 0);
caml_in_minor_collection = 0;
caml_stat_promoted_words += caml_allocated_words - prev_alloc_words;
++ caml_stat_minor_collections;
caml_final_empty_young ();
CAML_INSTR_TIME (tmr, "minor/finalized");
caml_stat_promoted_words += caml_allocated_words - prev_alloc_words;
CAML_INSTR_INT ("minor/promoted#", caml_allocated_words - prev_alloc_words);
++ caml_stat_minor_collections;
if (caml_minor_gc_end_hook != NULL) (*caml_minor_gc_end_hook) ();
}else{
caml_final_empty_young ();
@ -277,34 +348,83 @@ void caml_empty_minor_heap (void)
#ifdef DEBUG
{
value *p;
for (p = caml_young_start; p < caml_young_end; ++p){
for (p = caml_young_alloc_start; p < caml_young_alloc_end; ++p){
*p = Debug_free_minor;
}
++ minor_gc_counter;
}
#endif
}
/* Do a minor collection and a slice of major collection, call finalisation
#ifdef CAML_INSTR
extern uintnat caml_instr_alloc_jump;
#endif
/* Do a minor collection or a slice of major collection, call finalisation
functions, etc.
Leave the minor heap empty.
Leave enough room in the minor heap to allocate at least one object.
*/
CAMLexport void caml_gc_dispatch (void)
{
value *trigger = caml_young_trigger; /* save old value of trigger */
#ifdef CAML_INSTR
CAML_INSTR_SETUP(tmr, "dispatch");
CAML_INSTR_TIME (tmr, "overhead");
CAML_INSTR_INT ("alloc/jump#", caml_instr_alloc_jump);
caml_instr_alloc_jump = 0;
#endif
if (trigger == caml_young_alloc_start || caml_requested_minor_gc){
/* The minor heap is full, we must do a minor collection. */
/* reset the pointers first because the end hooks might allocate */
caml_requested_minor_gc = 0;
caml_young_trigger = caml_young_alloc_mid;
caml_young_limit = caml_young_trigger;
caml_empty_minor_heap ();
/* The minor heap is empty, we can start a major collection. */
if (caml_gc_phase == Phase_idle) caml_major_collection_slice (-1);
CAML_INSTR_TIME (tmr, "dispatch/minor");
caml_final_do_calls ();
CAML_INSTR_TIME (tmr, "dispatch/finalizers");
while (caml_young_ptr - caml_young_alloc_start < Max_young_whsize){
/* The finalizers or the hooks have filled up the minor heap, we must
repeat the minor collection. */
caml_requested_minor_gc = 0;
caml_young_trigger = caml_young_alloc_mid;
caml_young_limit = caml_young_trigger;
caml_empty_minor_heap ();
/* The minor heap is empty, we can start a major collection. */
if (caml_gc_phase == Phase_idle) caml_major_collection_slice (-1);
CAML_INSTR_TIME (tmr, "dispatch/finalizers_minor");
}
}
if (trigger != caml_young_alloc_start || caml_requested_major_slice){
/* The minor heap is half-full, do a major GC slice. */
caml_requested_major_slice = 0;
caml_young_trigger = caml_young_alloc_start;
caml_young_limit = caml_young_trigger;
caml_major_collection_slice (-1);
CAML_INSTR_TIME (tmr, "dispatch/major");
}
}
/* For backward compatibility with Lablgtk: do a minor collection to
ensure that the minor heap is empty.
*/
CAMLexport void caml_minor_collection (void)
{
caml_empty_minor_heap ();
caml_major_collection_slice (0);
caml_force_major_slice = 0;
caml_final_do_calls ();
caml_empty_minor_heap ();
caml_requested_minor_gc = 1;
caml_gc_dispatch ();
}
CAMLexport value caml_check_urgent_gc (value extra_root)
{
CAMLparam1 (extra_root);
if (caml_force_major_slice) caml_minor_collection();
if (caml_requested_major_slice || caml_requested_minor_gc){
CAML_INSTR_INT ("force_minor/check_urgent_gc@", 1);
caml_gc_dispatch();
}
CAMLreturn (extra_root);
}
@ -316,13 +436,14 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl)
if (tbl->base == NULL){
caml_alloc_table (tbl, caml_minor_heap_wsz / 8, 256);
}else if (tbl->limit == tbl->threshold){
CAML_INSTR_INT ("request_minor/realloc_ref_table@", 1);
caml_gc_message (0x08, "ref_table threshold crossed\n", 0);
tbl->limit = tbl->end;
caml_urge_major_slice ();
}else{ /* This will almost never happen with the bytecode interpreter. */
caml_request_minor_gc ();
}else{
asize_t sz;
asize_t cur_ptr = tbl->ptr - tbl->base;
Assert (caml_force_major_slice);
CAMLassert (caml_requested_minor_gc);
tbl->size *= 2;
sz = (tbl->size + tbl->reserve) * sizeof (value *);

81
byterun/misc.c
View File

@ -17,6 +17,7 @@
#include "caml/config.h"
#include "caml/misc.h"
#include "caml/memory.h"
#include "caml/version.h"
caml_timing_hook caml_major_slice_begin_hook = NULL;
caml_timing_hook caml_major_slice_end_hook = NULL;
@ -49,7 +50,7 @@ uintnat caml_verb_gc = 0;
void caml_gc_message (int level, char *msg, uintnat arg)
{
if (level < 0 || (caml_verb_gc & level) != 0){
if ((caml_verb_gc & level) != 0){
fprintf (stderr, msg, arg);
fflush (stderr);
}
@ -195,3 +196,81 @@ int caml_runtime_warnings_active(void)
}
return 1;
}
#ifdef CAML_INSTR
/* Timers for profiling GC and allocation (experimental, Linux-only) */
#include <limits.h>
#include <sys/types.h>
#include <unistd.h>
struct CAML_INSTR_BLOCK *CAML_INSTR_LOG = NULL;
intnat CAML_INSTR_STARTTIME, CAML_INSTR_STOPTIME;
#define Get_time(p,i) ((p)->ts[(i)].tv_nsec + 1000000000 * (p)->ts[(i)].tv_sec)
void CAML_INSTR_INIT (void)
{
char *s;
CAML_INSTR_STARTTIME = 0;
s = getenv ("OCAML_INSTR_START");
if (s != NULL) CAML_INSTR_STARTTIME = atol (s);
CAML_INSTR_STOPTIME = LONG_MAX;
s = getenv ("OCAML_INSTR_STOP");
if (s != NULL) CAML_INSTR_STOPTIME = atol (s);
}
void CAML_INSTR_ATEXIT (void)
{
int i;
struct CAML_INSTR_BLOCK *p, *prev, *next;
FILE *f = NULL;
char *fname;
fname = getenv ("OCAML_INSTR_FILE");
if (fname != NULL){
char *mode = "a";
char buf [1000];
char *name = fname;
if (name[0] == '@'){
snprintf (buf, sizeof(buf), "%s.%d", name + 1, getpid ());
name = buf;
}
if (name[0] == '+'){
mode = "a";
name = name + 1;
}else if (name [0] == '>' || name[0] == '-'){
mode = "w";
name = name + 1;
}
f = fopen (name, mode);
}
if (f != NULL){
/* reverse the list */
prev = NULL;
p = CAML_INSTR_LOG;
while (p != NULL){
next = p->next;
p->next = prev;
prev = p;
p = next;
}
CAML_INSTR_LOG = prev;
fprintf (f, "==== OCAML INSTRUMENTATION DATA %s\n", OCAML_VERSION_STRING);
for (p = CAML_INSTR_LOG; p != NULL; p = p->next){
for (i = 0; i < p->index; i++){
fprintf (f, "@@ %19ld %19ld %s\n",
Get_time (p, i), Get_time(p, i+1), p->tag[i+1]);
}
if (p->tag[0][0] != '\000'){
fprintf (f, "@@ %19ld %19ld %s\n",
Get_time (p, 0), Get_time(p, p->index), p->tag[0]);
}
}
fclose (f);
}
}
#endif /* CAML_INSTR */

10
byterun/obj.c
View File

@ -111,9 +111,13 @@ CAMLprim value caml_obj_dup(value arg)
to 0 or greater than the current size.
algorithm:
Change the length field of the header. Make up a white object
Change the length field of the header. Make up a black object
with the leftover part of the object: this is needed in the major
heap and harmless in the minor heap.
heap and harmless in the minor heap. The object cannot be white
because there may still be references to it in the ref table. By
using a black object we ensure that the ref table will be emptied
before the block is reallocated (since there must be a minor
collection within each major cycle).
[newsize] is a value encoding a number of words.
*/
@ -147,7 +151,7 @@ CAMLprim value caml_obj_truncate (value v, value newsize)
look like a pointer because there may be some references to it in
ref_table. */
Field (v, new_wosize) =
Make_header (Wosize_whsize (wosize-new_wosize), 1, Caml_white);
Make_header (Wosize_whsize (wosize-new_wosize), Abstract_tag, Caml_black);
Hd_val (v) = Make_header (new_wosize, tag, color);
return Val_unit;
}

23
byterun/roots.c
View File

@ -27,7 +27,7 @@ CAMLexport struct caml__roots_block *caml_local_roots = NULL;
CAMLexport void (*caml_scan_roots_hook) (scanning_action f) = NULL;
/* FIXME should rename to [caml_oldify_young_roots] and synchronise with
/* FIXME should rename to [caml_oldify_minor_roots] and synchronise with
asmrun/roots.c */
/* Call [caml_oldify_one] on (at least) all the roots that point to the minor
heap. */
@ -60,23 +60,38 @@ void caml_oldify_local_roots (void)
/* Call [caml_darken] on all roots */
void caml_darken_all_roots (void)
void caml_darken_all_roots_start (void)
{
caml_do_roots (caml_darken);
caml_do_roots (caml_darken, 1);
}
void caml_do_roots (scanning_action f)
uintnat caml_incremental_roots_count = 1;
intnat caml_darken_all_roots_slice (intnat work)
{
return work;
}
/* Note, in byte-code there is only one global root, so [do_globals] is
ignored and [caml_darken_all_roots_slice] does nothing. */
void caml_do_roots (scanning_action f, int do_globals)
{
CAML_INSTR_SETUP (tmr, "major_roots");
/* Global variables */
f(caml_global_data, &caml_global_data);
CAML_INSTR_TIME (tmr, "major_roots/global");
/* The stack and the local C roots */
caml_do_local_roots(f, caml_extern_sp, caml_stack_high, caml_local_roots);
CAML_INSTR_TIME (tmr, "major_roots/local");
/* Global C roots */
caml_scan_global_roots(f);
CAML_INSTR_TIME (tmr, "major_roots/C");
/* Finalised values */
caml_final_do_strong_roots (f);
CAML_INSTR_TIME (tmr, "major_roots/finalised");
/* Hook */
if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);
CAML_INSTR_TIME (tmr, "major_roots/hook");
}
CAMLexport void caml_do_local_roots (scanning_action f, value *stack_low,

22
byterun/signals.c
View File

@ -67,7 +67,7 @@ void caml_record_signal(int signal_number)
#ifndef NATIVE_CODE
caml_something_to_do = 1;
#else
caml_young_limit = caml_young_end;
caml_young_limit = caml_young_alloc_end;
#endif
}
@ -157,15 +157,16 @@ void caml_execute_signal(int signal_number, int in_signal_handler)
/* Arrange for a garbage collection to be performed as soon as possible */
int volatile caml_force_major_slice = 0;
int volatile caml_requested_major_slice = 0;
int volatile caml_requested_minor_gc = 0;
void caml_urge_major_slice (void)
void caml_request_major_slice (void)
{
caml_force_major_slice = 1;
caml_requested_major_slice = 1;
#ifndef NATIVE_CODE
caml_something_to_do = 1;
#else
caml_young_limit = caml_young_end;
caml_young_limit = caml_young_alloc_end;
/* This is only moderately effective on ports that cache [caml_young_limit]
in a register, since [caml_modify] is called directly, not through
[caml_c_call], so it may take a while before the register is reloaded
@ -173,6 +174,17 @@ void caml_urge_major_slice (void)
#endif
}
void caml_request_minor_gc (void)
{
caml_requested_minor_gc = 1;
#ifndef NATIVE_CODE
caml_something_to_do = 1;
#else
caml_young_limit = caml_young_alloc_end;
/* Same remark as above in [caml_request_major_slice]. */
#endif
}
/* OS-independent numbering of signals */
#ifndef SIGABRT

10
byterun/startup.c
View File

@ -287,9 +287,13 @@ CAMLexport void caml_main(char **argv)
caml_external_raise = NULL;
/* Determine options and position of bytecode file */
#ifdef DEBUG
caml_verb_gc = 0xBF;
caml_verb_gc = 0x3F;
#endif
caml_parse_ocamlrunparam();
#ifdef DEBUG
caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0);
#endif
pos = 0;
/* First, try argv[0] (when ocamlrun is called by a bytecode program) */
@ -326,7 +330,7 @@ CAMLexport void caml_main(char **argv)
/* Initialize the abstract machine */
caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz,
caml_init_heap_chunk_sz, caml_init_percent_free,
caml_init_max_percent_free);
caml_init_max_percent_free, caml_init_major_window);
caml_init_stack (caml_init_max_stack_wsz);
caml_init_atom_table();
caml_init_backtrace();
@ -410,7 +414,7 @@ CAMLexport void caml_startup_code(
/* Initialize the abstract machine */
caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz,
caml_init_heap_chunk_sz, caml_init_percent_free,
caml_init_max_percent_free);
caml_init_max_percent_free, caml_init_major_window);
caml_init_stack (caml_init_max_stack_wsz);
caml_init_atom_table();
caml_init_backtrace();

3
byterun/startup_aux.c
View File

@ -42,6 +42,7 @@ uintnat caml_init_minor_heap_wsz = Minor_heap_def;
uintnat caml_init_heap_chunk_sz = Heap_chunk_def;
uintnat caml_init_heap_wsz = Init_heap_def;
uintnat caml_init_max_stack_wsz = Max_stack_def;
uintnat caml_init_major_window = Major_window_def;
extern int caml_parser_trace;
uintnat caml_trace_level = 0;
@ -73,6 +74,7 @@ void caml_parse_ocamlrunparam(void)
case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break;
case 'b': scanmult (opt, &p); caml_record_backtrace(Val_bool (p)); break;
case 'h': scanmult (opt, &caml_init_heap_wsz); break;
case 'H': scanmult (opt, &caml_use_huge_pages); break;
case 'i': scanmult (opt, &caml_init_heap_chunk_sz); break;
case 'l': scanmult (opt, &caml_init_max_stack_wsz); break;
case 'o': scanmult (opt, &caml_init_percent_free); break;
@ -82,6 +84,7 @@ void caml_parse_ocamlrunparam(void)
case 's': scanmult (opt, &caml_init_minor_heap_wsz); break;
case 't': scanmult (opt, &caml_trace_level); break;
case 'v': scanmult (opt, &caml_verb_gc); break;
case 'w': scanmult (opt, &caml_init_major_window); break;
case 'W': scanmult (opt, &caml_runtime_warnings); break;
}
while (*opt != '\0'){

6
byterun/sys.c
View File

@ -44,14 +44,15 @@
#include "caml/alloc.h"
#include "caml/debugger.h"
#include "caml/fail.h"
#include "caml/gc_ctrl.h"
#include "caml/instruct.h"
#include "caml/io.h"
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "caml/osdeps.h"
#include "caml/signals.h"
#include "caml/stacks.h"
#include "caml/sys.h"
#include "caml/gc_ctrl.h"
#include "caml/io.h"
static char * error_message(void)
{
@ -135,6 +136,7 @@ CAMLprim value caml_sys_exit(value retcode)
#ifndef NATIVE_CODE
caml_debugger(PROGRAM_EXIT);
#endif
CAML_INSTR_ATEXIT ();
exit(Int_val(retcode));
return Val_unit;
}

6
byterun/weak.c
View File

@ -51,11 +51,7 @@ static void do_set (value ar, mlsize_t offset, value v)
value old = Field (ar, offset);
Field (ar, offset) = v;
if (!(Is_block (old) && Is_young (old))){
if (caml_weak_ref_table.ptr >= caml_weak_ref_table.limit){
CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.limit);
caml_realloc_ref_table (&caml_weak_ref_table);
}
*caml_weak_ref_table.ptr++ = &Field (ar, offset);
add_to_ref_table (&caml_weak_ref_table, &Field (ar, offset));
}
}else{
Field (ar, offset) = v;

Some files were not shown because too many files have changed in this diff Show More