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

remake .depend

master
Mark Shinwell 2016-01-12 15:18:58 +01:00
parent b53e5789bc 16c45bfe14
commit cf06b87981
239 changed files with 24169 additions and 689 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

221
.depend
View File

@ -1,8 +1,10 @@
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 :
@ -11,14 +13,18 @@ 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
@ -122,10 +128,10 @@ typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \
typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
typing/path.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi utils/consistbl.cmi parsing/asttypes.cmi
typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
typing/ident.cmi :
typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi
typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
@ -144,10 +150,10 @@ typing/path.cmi : typing/ident.cmi
typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
typing/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \
parsing/location.cmi
typing/printtyped.cmi : typing/typedtree.cmi
typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \
typing/env.cmi parsing/asttypes.cmi
typing/printtyped.cmi : typing/typedtree.cmi
typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
typing/annot.cmi
typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
@ -163,11 +169,11 @@ typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/includecore.cmi typing/ident.cmi typing/env.cmi \
parsing/asttypes.cmi
typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
typing/typedtreeMap.cmi : typing/typedtree.cmi
typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
typing/typedtreeMap.cmi : typing/typedtree.cmi
typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/includemod.cmi typing/ident.cmi typing/env.cmi \
@ -211,12 +217,6 @@ typing/datarepr.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \
typing/datarepr.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \
typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/datarepr.cmi
typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \
parsing/asttypes.cmi typing/envaux.cmi
typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \
parsing/asttypes.cmi typing/envaux.cmi
typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
@ -229,6 +229,12 @@ typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
typing/cmi_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
typing/btype.cmx parsing/asttypes.cmi typing/env.cmi
typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \
parsing/asttypes.cmi typing/envaux.cmi
typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \
parsing/asttypes.cmi typing/envaux.cmi
typing/ident.cmo : typing/ident.cmi
typing/ident.cmx : typing/ident.cmi
typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
@ -293,12 +299,6 @@ typing/primitive.cmo : utils/warnings.cmi parsing/parsetree.cmi \
typing/primitive.cmx : utils/warnings.cmx parsing/parsetree.cmi \
typing/outcometree.cmi utils/misc.cmx parsing/location.cmx \
parsing/attr_helper.cmx typing/primitive.cmi
typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \
typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi
typing/printtyped.cmx : typing/typedtree.cmx parsing/printast.cmx \
typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
typing/ident.cmx parsing/asttypes.cmi typing/printtyped.cmi
typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \
@ -311,6 +311,12 @@ typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \
parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \
parsing/asttypes.cmi typing/printtyp.cmi
typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \
typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi
typing/printtyped.cmx : typing/typedtree.cmx parsing/printast.cmx \
typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
typing/ident.cmx parsing/asttypes.cmi typing/printtyped.cmi
typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \
parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \
@ -379,14 +385,6 @@ typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
utils/clflags.cmx typing/btype.cmx parsing/attr_helper.cmx \
parsing/asttypes.cmi parsing/ast_helper.cmx typing/typedecl.cmi
typing/typedtreeIter.cmo : typing/typedtree.cmi utils/misc.cmi \
parsing/asttypes.cmi typing/typedtreeIter.cmi
typing/typedtreeIter.cmx : typing/typedtree.cmx utils/misc.cmx \
parsing/asttypes.cmi typing/typedtreeIter.cmi
typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \
typing/typedtreeMap.cmi
typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \
typing/typedtreeMap.cmi
typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \
@ -395,6 +393,14 @@ typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \
typing/typedtree.cmi
typing/typedtreeIter.cmo : typing/typedtree.cmi utils/misc.cmi \
parsing/asttypes.cmi typing/typedtreeIter.cmi
typing/typedtreeIter.cmx : typing/typedtree.cmx utils/misc.cmx \
parsing/asttypes.cmi typing/typedtreeIter.cmi
typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \
typing/typedtreeMap.cmi
typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \
typing/typedtreeMap.cmi
typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \
@ -656,28 +662,34 @@ bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \
bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \
typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx typing/btype.cmx bytecomp/typeopt.cmi
asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi
asmcomp/CSEgen.cmi : asmcomp/mach.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 \
bytecomp/debuginfo.cmi parsing/asttypes.cmi
asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
asmcomp/clambda.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 : utils/timings.cmi typing/ident.cmi \
asmcomp/cmx_format.cmi asmcomp/clambda.cmi
asmcomp/CSEgen.cmi : asmcomp/mach.cmi
asmcomp/deadcode.cmi : asmcomp/mach.cmi
asmcomp/emitaux.cmi : bytecomp/debuginfo.cmi
asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.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 \
bytecomp/debuginfo.cmi
@ -690,8 +702,8 @@ asmcomp/printlinear.cmi : asmcomp/linearize.cmi
asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/reg.cmi : typing/ident.cmi asmcomp/cmm.cmi
asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/reload.cmi : asmcomp/mach.cmi
asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi
asmcomp/scheduling.cmi : asmcomp/linearize.cmi
asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
@ -700,11 +712,18 @@ asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi
asmcomp/spill.cmi : asmcomp/mach.cmi
asmcomp/split.cmi : asmcomp/mach.cmi
asmcomp/strmatch.cmi : asmcomp/cmm.cmi
asmcomp/un_anf.cmi : asmcomp/clambda.cmi
asmcomp/x86_ast.cmi :
asmcomp/x86_dsl.cmi : asmcomp/x86_ast.cmi
asmcomp/x86_gas.cmi : asmcomp/x86_ast.cmi
asmcomp/x86_masm.cmi : asmcomp/x86_ast.cmi
asmcomp/x86_proc.cmi : asmcomp/x86_ast.cmi
asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo
asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx
asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/cmm.cmi asmcomp/CSEgen.cmi
asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
asmcomp/cmm.cmx asmcomp/CSEgen.cmi
asmcomp/arch.cmo : utils/clflags.cmi
asmcomp/arch.cmx : utils/clflags.cmx
asmcomp/asmgen.cmo : bytecomp/translmod.cmi utils/timings.cmi \
@ -757,30 +776,42 @@ asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.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_intf.cmo : asmcomp/linearize.cmi asmcomp/arch.cmo
asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/arch.cmx
asmcomp/branch_relaxation.cmo : utils/misc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/branch_relaxation_intf.cmo \
asmcomp/branch_relaxation.cmi
asmcomp/branch_relaxation.cmx : utils/misc.cmx asmcomp/mach.cmx \
asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/branch_relaxation_intf.cmx \
asmcomp/branch_relaxation.cmi
asmcomp/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 \
bytecomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \
bytecomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/closure.cmo : utils/warnings.cmi utils/tbl.cmi bytecomp/switch.cmi \
bytecomp/simplif.cmi typing/primitive.cmi utils/misc.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
bytecomp/debuginfo.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
asmcomp/closure.cmi
asmcomp/closure.cmx : utils/warnings.cmx utils/tbl.cmx bytecomp/switch.cmx \
bytecomp/simplif.cmx typing/primitive.cmx utils/misc.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
bytecomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
asmcomp/closure.cmi
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 bytecomp/debuginfo.cmi \
@ -793,36 +824,22 @@ asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx \
utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/clambda.cmx \
parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/cmmgen.cmi
asmcomp/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/coloring.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi
asmcomp/coloring.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi
asmcomp/comballoc.cmo : asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \
asmcomp/arch.cmo asmcomp/comballoc.cmi
asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \
asmcomp/arch.cmx asmcomp/comballoc.cmi
asmcomp/compilenv.cmo : utils/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/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/cmm.cmi asmcomp/CSEgen.cmi
asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
asmcomp/cmm.cmx asmcomp/CSEgen.cmi
asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo
asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx
asmcomp/compilenv.cmo : utils/warnings.cmi 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/emitaux.cmo : asmcomp/linearize.cmi bytecomp/debuginfo.cmi \
utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
asmcomp/emitaux.cmx : asmcomp/linearize.cmx bytecomp/debuginfo.cmx \
utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/emit.cmo : asmcomp/x86_proc.cmi asmcomp/x86_masm.cmi \
asmcomp/x86_gas.cmi asmcomp/x86_dsl.cmi asmcomp/x86_ast.cmi \
asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi \
@ -837,6 +854,28 @@ asmcomp/emit.cmx : asmcomp/x86_proc.cmx asmcomp/x86_masm.cmx \
bytecomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/branch_relaxation.cmx \
asmcomp/arch.cmx asmcomp/emit.cmi
asmcomp/emitaux.cmo : asmcomp/linearize.cmi bytecomp/debuginfo.cmi \
utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
asmcomp/emitaux.cmx : asmcomp/linearize.cmx bytecomp/debuginfo.cmx \
utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/export_info.cmo : 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 \
@ -889,14 +928,14 @@ asmcomp/proc.cmx : asmcomp/x86_proc.cmx asmcomp/reg.cmx utils/misc.cmx \
asmcomp/proc.cmi
asmcomp/reg.cmo : typing/ident.cmi asmcomp/cmm.cmi asmcomp/reg.cmi
asmcomp/reg.cmx : typing/ident.cmx asmcomp/cmm.cmx asmcomp/reg.cmi
asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/reloadgen.cmi
asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
asmcomp/cmm.cmi utils/clflags.cmi asmcomp/reload.cmi
asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/reload.cmi
asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/reloadgen.cmi
asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/schedgen.cmi
@ -931,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 \
@ -951,8 +998,8 @@ driver/compenv.cmi :
driver/compile.cmi :
driver/compmisc.cmi : typing/env.cmi
driver/errors.cmi :
driver/main_args.cmi :
driver/main.cmi :
driver/main_args.cmi :
driver/optcompile.cmi :
driver/opterrors.cmi :
driver/optmain.cmi :
@ -989,8 +1036,6 @@ driver/compmisc.cmx : typing/typemod.cmx utils/misc.cmx \
parsing/asttypes.cmi driver/compmisc.cmi
driver/errors.cmo : parsing/location.cmi driver/errors.cmi
driver/errors.cmx : parsing/location.cmx driver/errors.cmi
driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
driver/main.cmo : utils/warnings.cmi utils/timings.cmi utils/misc.cmi \
driver/main_args.cmi parsing/location.cmi utils/config.cmi \
driver/compmisc.cmi driver/compile.cmi driver/compenv.cmi \
@ -1001,6 +1046,8 @@ driver/main.cmx : utils/warnings.cmx utils/timings.cmx utils/misc.cmx \
driver/compmisc.cmx driver/compile.cmx driver/compenv.cmx \
utils/clflags.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx driver/main.cmi
driver/main_args.cmo : utils/warnings.cmi 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 \
utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \
@ -1079,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 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
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 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
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 \

4
.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
@ -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

30
Changes
View File

@ -101,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,
@ -131,6 +133,9 @@ Compilers:
(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)
@ -172,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
@ -233,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
@ -246,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
@ -295,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
@ -401,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
@ -425,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
@ -493,6 +517,8 @@ Features wishes:
(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):
---------------------------

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) \

4
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/timings.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

18
asmcomp/asmgen.ml
View File

@ -100,7 +100,7 @@ let compile_genfuns ppf f =
| _ -> ())
(Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
let compile_unit ~sourcefile 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
@ -114,7 +114,7 @@ let compile_unit ~sourcefile asm_filename keep_asm obj_filename gen =
raise exn
end;
let assemble_result =
Timings.(time (Assemble sourcefile))
Timings.(time (Assemble source_provenance))
(Proc.assemble_file asm_filename) obj_filename
in
if assemble_result <> 0
@ -124,12 +124,12 @@ let compile_unit ~sourcefile asm_filename keep_asm obj_filename gen =
remove_file obj_filename;
raise exn
let gen_implementation ?toplevel ~sourcefile ppf (size, lam) =
let gen_implementation ?toplevel ~source_provenance ppf (size, lam) =
Emit.begin_assembly ();
Timings.(time (Clambda sourcefile)) (Closure.intro size) lam
Timings.(time (Clambda source_provenance)) (Closure.intro size) lam
++ clambda_dump_if ppf
++ Timings.(time (Cmm sourcefile)) (Cmmgen.compunit size)
++ Timings.(time (Compile_phrases sourcefile))
++ 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);
@ -147,14 +147,14 @@ let gen_implementation ?toplevel ~sourcefile ppf (size, lam) =
);
Emit.end_assembly ()
let compile_implementation ?toplevel ~sourcefile 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 sourcefile asmfile !keep_asm_file (prefixname ^ ext_obj)
(fun () -> gen_implementation ?toplevel ~sourcefile 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 *)

4
asmcomp/asmgen.mli
View File

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

4
asmcomp/asmlink.ml
View File

@ -268,7 +268,7 @@ let link_shared ppf objfiles output_name =
then output_name ^ ".startup" ^ ext_asm
else Filename.temp_file "camlstartup" ext_asm in
let startup_obj = output_name ^ ".startup" ^ ext_obj in
Asmgen.compile_unit ~sourcefile:"startup"
Asmgen.compile_unit ~source_provenance:Timings.Startup
startup !Clflags.keep_startup_file startup_obj
(fun () ->
make_shared_startup_file ppf
@ -327,7 +327,7 @@ let link ppf objfiles output_name =
then output_name ^ ".startup" ^ ext_asm
else Filename.temp_file "camlstartup" ext_asm in
let startup_obj = Filename.temp_file "camlstartup" ext_obj in
Asmgen.compile_unit ~sourcefile:"startup"
Asmgen.compile_unit ~source_provenance:Timings.Startup
startup !Clflags.keep_startup_file startup_obj
(fun () -> make_startup_file ppf units_tolink);
Misc.try_finally

2
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 ~sourcefile:"pack"
Asmgen.compile_implementation ~source_provenance:(Timings.Pack targetname)
(chop_extension_if_any objtemp) ppf
(Translmod.transl_store_package
components (Ident.create_persistent targetname) coercion);

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

3
asmcomp/clambda.ml
View File

@ -28,7 +28,7 @@ type ustructured_constant =
| Uconst_string of string
and uconstant =
| Uconst_ref of string * ustructured_constant
| Uconst_ref of string * ustructured_constant option
| Uconst_int of int
| Uconst_ptr of int
@ -53,6 +53,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;

3
asmcomp/clambda.mli
View File

@ -28,7 +28,7 @@ type ustructured_constant =
| Uconst_string of string
and uconstant =
| Uconst_ref of string * ustructured_constant
| Uconst_ref of string * ustructured_constant option
| Uconst_int of int
| Uconst_ptr of int
@ -53,6 +53,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;

59
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
@ -180,6 +181,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
@ -203,7 +205,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)
@ -265,7 +267,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)
@ -273,8 +275,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)
@ -284,7 +286,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)
@ -293,8 +295,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)
@ -310,7 +312,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 ->
@ -322,7 +324,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)
@ -331,8 +333,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)
@ -346,7 +348,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 ->
@ -358,7 +360,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)
@ -367,8 +369,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)
@ -382,7 +384,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 ->
@ -400,7 +402,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
@ -417,19 +420,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] ->
@ -547,7 +550,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
@ -610,6 +613,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 *)
@ -783,7 +788,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
@ -1258,9 +1263,10 @@ 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
@ -1296,6 +1302,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
@ -1311,7 +1318,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

23
asmcomp/cmmgen.ml
View File

@ -1318,10 +1318,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
@ -1642,6 +1645,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 =
@ -2190,15 +2195,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
@ -2940,7 +2945,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)

30
asmcomp/compilenv.ml
View File

@ -160,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;
@ -200,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

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

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

5
asmcomp/printclambda.ml
View File

@ -33,8 +33,9 @@ let rec structured_constant ppf = function
| Uconst_string s -> fprintf ppf "%S" s
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
@ -157,6 +158,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) ->

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

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;
}

94
bytecomp/printlambda.ml
View File

@ -246,6 +246,100 @@ let primitive ppf = function
| Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
| Pint_as_pointer -> fprintf ppf "int_as_pointer"
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@ ";

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

84
bytecomp/translmod.ml
View File

@ -359,7 +359,7 @@ 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 =
@ -407,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;
@ -430,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
@ -449,33 +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,
Translattribute.add_inline_attribute
(transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr)
mb.mb_loc mb.mb_attributes,
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
@ -484,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 _
@ -539,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). *)
@ -913,7 +938,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
@ -982,7 +1007,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

8
byterun/caml/config.h
View File

@ -113,14 +113,6 @@ typedef uint64_t uintnat;
#endif
/* We use static inline functions in some cases instead of duplicating
code but the MSVC compiler has a slightly different syntax. */
#ifdef _MSC_VER
#define inline _inline
#endif
/* We use threaded code interpretation if the compiler provides labels
as first-class values (GCC 2.x). */

2
byterun/caml/misc.h
View File

@ -196,7 +196,7 @@ 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

11
byterun/instrtrace.c
View File

@ -183,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);
@ -250,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++) {

35
byterun/win32.c
View File

@ -38,7 +38,10 @@
#include "caml/signals.h"
#include "caml/sys.h"
#include "caml/config.h"
#ifdef SUPPORT_DYNAMIC_LINKING
#include <flexdll.h>
#endif
#ifndef S_ISREG
#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
@ -189,6 +192,8 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name)
return res;
}
#ifdef SUPPORT_DYNAMIC_LINKING
void * caml_dlopen(char * libname, int for_execution, int global)
{
void *handle;
@ -222,6 +227,34 @@ char * caml_dlerror(void)
return flexdll_dlerror();
}
#else
void * caml_dlopen(char * libname, int for_execution, int global)
{
return NULL;
}
void caml_dlclose(void * handle)
{
}
void * caml_dlsym(void * handle, char * name)
{
return NULL;
}
void * caml_globalsym(char * name)
{
return NULL;
}
char * caml_dlerror(void)
{
return "dynamic loading not supported on this platform";
}
#endif
/* Proper emulation of signal(), including ctrl-C and ctrl-break */
typedef void (*sighandler)(int sig);
@ -577,6 +610,7 @@ int caml_executable_name(char * name, int name_len)
/* snprintf emulation */
#if defined(_WIN32) && !defined(_UCRT)
int caml_snprintf(char * buf, size_t size, const char * format, ...)
{
int len;
@ -601,3 +635,4 @@ int caml_snprintf(char * buf, size_t size, const char * format, ...)
va_end(args);
return len;
}
#endif

2
config/m-nt.h
View File

@ -40,7 +40,7 @@
#endif
#define ARCH_INT64_PRINTF_FORMAT "I64"
#if !defined(__MINGW32__) && !defined(__cplusplus) && !defined(inline)
#if defined(_MSC_VER) && !defined(__cplusplus)
#define inline __inline
#endif

1
config/s-nt.h
View File

@ -31,3 +31,4 @@
#define HAS_BROKEN_PRINTF
#define HAS_IPV6
#define HAS_NICE
#define SUPPORT_DYNAMIC_LINKING

11
configure vendored
View File

@ -48,6 +48,7 @@ with_ocamldoc=ocamldoc
with_ocamlbuild=ocamlbuild
with_frame_pointers=false
no_naked_pointers=false
native_compiler=true
TOOLPREF=""
with_cfi=true
@ -159,6 +160,8 @@ while : ; do
no_naked_pointers=true;;
-no-cfi|--no-cfi)
with_cfi=false;;
-no-native-compiler)
native_compiler=false;;
*) if echo "$1" | grep -q -e '^--\?[a-zA-Z0-9-]\+='; then
err "configure expects arguments of the form '-prefix /foo/bar'," \
"not '-prefix=/foo/bar' (note the '=')."
@ -375,7 +378,7 @@ case "$bytecc,$target" in
bytecccompopts="$bytecccompopts -DUMK";;
*,powerpc-*-aix*)
# Avoid name-space pollution by requiring Unix98-conformant includes
bytecccompopts="$bytecccompopts -D_XOPEN_SOURCE=500";;
bytecccompopts="$bytecccompopts -D_XOPEN_SOURCE=500 -D_ALL_SOURCE";;
*,*-*-cygwin*)
case $target in
i686-*) flavor=cygwin;;
@ -863,6 +866,12 @@ case "$arch64,$arch,$model" in
arch=none; model=default; system=unknown;;
esac
case "$native_compiler" in
true) ;;
false)
arch=none; model=default; system=unknown;;
esac
if test -z "$ccoption"; then
nativecc="$bytecc"
else

1
debugger/Makefile.shared
View File

@ -32,6 +32,7 @@ OTHEROBJS=\
$(UNIXDIR)/unix.cma \
../utils/config.cmo ../utils/tbl.cmo \
../utils/clflags.cmo ../utils/misc.cmo \
../utils/identifiable.cmo ../utils/numbers.cmo \
../utils/consistbl.cmo ../utils/warnings.cmo \
../utils/terminfo.cmo \
../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \

6
driver/optcompile.ml
View File

@ -59,12 +59,12 @@ let (++) x f = f x
let (+++) (x, y) f = (x, f y)
let implementation ppf sourcefile outputprefix =
let source_provenance = Timings.File sourcefile in
Compmisc.init_path true;
let modulename = module_of_filename ppf sourcefile outputprefix in
Env.set_unit_name modulename;
let env = Compmisc.initial_env() in
Compilenv.reset ~source_provenance:(Timings.File sourcefile)
?packname:!Clflags.for_package modulename;
Compilenv.reset ~source_provenance ?packname:!Clflags.for_package modulename;
let cmxfile = outputprefix ^ ".cmx" in
let objfile = outputprefix ^ ext_obj in
let comp ast =
@ -86,7 +86,7 @@ let implementation ppf sourcefile outputprefix =
(fun (size, lambda) ->
(size, Simplif.simplify_lambda lambda)
+++ print_if ppf Clflags.dump_lambda Printlambda.lambda
++ Asmgen.compile_implementation ~sourcefile outputprefix ppf;
++ Asmgen.compile_implementation ~source_provenance outputprefix ppf;
Compilenv.save_unit_info cmxfile)
end;
Warnings.check_fatal ();

44
emacs/caml-font.el
View File

@ -172,23 +172,28 @@
"'\\(\015\012\\|[\012\015]\\)"
)
; match an opening delimiter for a quoted string
(defconst caml-font-quoted-string-start-re
"{\\([a-z]*\\)|"
)
; match any token or sequence of tokens that cannot contain a
; quote, double quote, a start of comment, or a newline
; quote, double quote, a start of comment or quoted string, or a newline
; note: this is only to go faster than one character at a time
(defconst caml-font-other-re
"[^A-Za-z_0-9\012\015\300-\326\330-\366\370-\377'\"(]+"
"[^A-Za-z_0-9\012\015\300-\326\330-\366\370-\377'\"({]+"
)
; match any sequence of non-special characters in a comment
; note: this is only to go faster than one character at a time
(defconst caml-font-other-comment-re
"[^(*\"'\012\015]+"
"[^{(*\"'\012\015]+"
)
; match any sequence of non-special characters in a string
; note: this is only to go faster than one character at a time
(defconst caml-font-other-string-re
"[^\\\"\012\015]"
"[^|\\\"\012\015]"
)
; match a newline
@ -230,8 +235,9 @@
; depth is the depth of nested comments at this point
; it must be a non-negative integer
; st can be:
; nil -- we are in the base state
; t -- we are within a string
; nil -- we are in the base state
; t -- we are within a string
; a string -- we are within a quoted string and st is the closing delimiter
(defun caml-font-annotate (st depth)
(let ((continue t))
@ -254,6 +260,11 @@
'syntax-table (string-to-syntax "|"))
(goto-char (match-end 0))
(setq st t))
((caml-font-looking-at caml-font-quoted-string-start-re)
(put-text-property (point) (1+ (point))
'syntax-table (string-to-syntax "|"))
(goto-char (match-end 0))
(setq st (concat "|" (match-string 1) "}")))
((caml-font-looking-at "(\\*")
(put-text-property (point) (1+ (point))
'syntax-table (string-to-syntax "!"))
@ -297,7 +308,7 @@
(remove-text-properties (point) (1+ (point))
'(syntax-table nil caml-font-state nil))
(goto-char (1+ (point))))))
(t ; string state inside or outside a comment
((equal st t) ; string state inside or outside a comment
(cond
((caml-font-looking-at "\"")
(when (= depth 0)
@ -315,7 +326,24 @@
(t
(remove-text-properties (point) (1+ (point))
'(syntax-table nil caml-font-state nil))
(goto-char (1+ (point)))))))))
(goto-char (1+ (point))))))
((stringp st) ; quoted-string state inside or outside comment
(cond
((caml-font-looking-at st)
(when (= depth 0)
(put-text-property (1- (match-end 0)) (match-end 0)
'syntax-table (string-to-syntax "|")))
(goto-char (match-end 0))
(setq st nil))
((caml-font-looking-at caml-font-other-string-re)
(goto-char (match-end 0)))
(t
(remove-text-properties (point) (1+ (point))
'(syntax-table nil caml-font-state nil))
(goto-char (1+ (point))))))
(t ; should not happen
(remove-text-properties (point) (1+ (point))
'(syntax-table nil caml-font-state nil))))))
)
; This is the hook function for font-lock-extend-after-change-function

5
man/ocamlc.m
View File

@ -314,7 +314,7 @@ executable file, where
can find it and use it.
.TP
.BI \-for\-pack \ module\-path
Generate an object file (.cmx and .o files) that can later be included
Generate an object file (.cmo file) that can later be included
as a sub-module (with the given access path) of a compilation unit
constructed with
.BR \-pack .
@ -322,6 +322,9 @@ For instance,
.B ocamlc\ \-for\-pack\ P\ \-c\ A.ml
will generate a.cmo that can later be used with
.BR "ocamlc -pack -o P.cmo a.cmo" .
Note: you can still pack a module that was compiled without
.B \-for\-pack
but in this case exceptions will be printed with the wrong names.
.TP
.B \-g
Add debugging information while compiling and linking. This option is

3
manual/manual/cmds/comp.etex
View File

@ -206,6 +206,9 @@ as a sub-module (with the given access path) of a compilation unit
constructed with "-pack". For instance, "ocamlc -for-pack P -c A.ml"
will generate "a.cmo" that can later be used with
"ocamlc -pack -o P.cmo a.cmo".
Note: you can still pack a module that was compiled without
"-for-pack"
but in this case exceptions will be printed with the wrong names.
\item["-g"]
Add debugging information while compiling and linking. This option is

10
manual/manual/cmds/ocamldoc.etex
View File

@ -1105,9 +1105,10 @@ Compilation of "custom.ml" can be performed by the following command~:
\begin{alltt}
ocamldoc -g custom.cmo \var{other-options} \var{source-files}
\end{alltt}
\noindent{}It is important not to give the "-html" or any other option
selecting a built-in generator to "ocamldoc",
which would result in using this generator instead of the one you just loaded.
\noindent{}Options selecting a built-in generator to "ocamldoc", such as
"-html", have no effect if a custom generator of the same kind is provided using
"-g". If the kinds do not match, the selected built-in generator is used and the
custom one is ignored.
%%%%%%%%%%%%%%
\subsubsection{Defining a custom generator class in several files}
@ -1129,6 +1130,3 @@ ocamlc -o custom.cma -a \var{\nth{file}{1}}.cmo \var{\nth{file}{2}}.cmo ... \var
\begin{alltt}
ocamldoc -g custom.cma \var{other-options} \var{source-files}
\end{alltt}
\noindent{}Again, it is important not to give the "-html" or any other
option selecting a built-in generator to "ocamldoc",
which would result in using this generator instead of the one you just loaded.

123
manual/manual/refman/exten.etex
View File

@ -1511,7 +1511,7 @@ Some attributes are understood by the type-checker:
in which case its scope is limited to that expression.
Note that it is not well-defined which scope is used for a specific
warning. This is implementation dependant and can change between versions.
For instance, warnings triggerd by the ``ppwarning'' attribute (see below)
For instance, warnings triggered by the ``ppwarning'' attribute (see below)
are issued using the global warning configuration.
\item
``ocaml.warnerror'' or ``warnerror'', with a string literal payload.
@ -1539,6 +1539,34 @@ Some attributes are understood by the type-checker:
of the string payload). This is mostly useful for preprocessors which
need to communicate warnings to the user. This could also be used
to mark explicitly some code location for further inspection.
\item
``ocaml.warn_on_literal_pattern'' or ``warn_on_literal_pattern'' annotate
constructors in type definition. A warning (52) is then emitted when this
constructor is pattern matched with a constant literal as argument. This
attribute denotes constructors whose argument is purely informative and
may change in the future. Therefore, pattern matching on this argument
with a constant literal is unreliable. For instance, all built-in exception
constructors are marked as ``warn_on_literal_pattern''.
Note that, due to an implementation limitation, this warning (52) is only
triggered for single argument constructor.
\item
``ocaml.tailcall'' or ``tailcall'' can be applied to function
application in order to check that the call is tailcall optimized.
If it it not the case, a warning (51) is emitted.
\item
``ocaml.inline'' or ``inline'' take either ``never'', ``always''
or nothing as payload on a function or functor definition. If no payload
is provided, the default value is ``always''. This payload controls when
applications of the annotated functions should be inlined.
\item
``ocaml.inlined'' or ``inlined'' can be applied to any function or functor
application to check that the call is inlined by the compiler. If the call
is not inlined, a warning (55) is emitted.
\item
``ocaml.noalloc'', ``ocaml.unboxed''and ``ocaml.untagged'' or
``noalloc'', ``unboxed'' and ``untagged'' can be used on external
definitions to obtain finer control over the C-to-OCaml interface. See
\ref{s:C-cheaper-call} for more details.
\end{itemize}
\begin{verbatim}
@ -1546,16 +1574,31 @@ module X = struct
[@@@warning "+9"] (* locally enable warning 9 in this structure *)
...
end
[@@deprecated "Please is module 'Y' instead."]
[@@deprecated "Please use module 'Y' instead."]
let x = begin[@warning "+9] ... end in ....
type t = A | B
[@@deprecated "Please use type 's' instead.]
let f x =
assert (x >= 0) [@ppwarning "TODO: remove this later"];
let rec no_op = function
| [] -> ()
| _ :: q -> (no_op[@tailcall]) q;;
let f x = x [@@inline]
let () = (f[@inlined]) ()
type fragile =
| Int of int [@warn_on_literal_pattern]
| String of string [@warn_on_literal_pattern]
let f = function
| Int 0 | String "constant" -> () (* trigger warning 52 *)
| _ -> ()
....
\end{verbatim}
@ -1624,8 +1667,8 @@ class-field:
An infix form is available for extension nodes as expressions, when
the payload is a single expression. This form applies to all
expressions starting with one or two keywords: the percent sign and then
and extension identifier follow immediately the initial keyword(s).
expressions starting with one or two keywords: the first keyword
followed by the percent sign and then an extension identifier.
Examples:
@ -1641,6 +1684,27 @@ the attributes are considered to apply to the payload:
let%foo[@bar] x = 2 in x + 1 === [%foo (let x = 2 in x + 1) [@bar]]
\end{verbatim}
\subsection{Built-in extension nodes}
(Introduced in OCaml 4.03)
Some extension nodes are understood by the compiler itself:
\begin{itemize}
\item
``ocaml.extension_constructor'' or ``extension_constructor''
take as payload a constructor from an extensible variant type
(see \ref{s:extensible-variants}) and return its extension
constructor slot.
\end{itemize}
\begin{verbatim}
type t = ..
type t += X of int | Y of string
let x = [%extension_constructor X]
let y = [%extension_constructor Y]
let () = assert (x <> y)
\end{verbatim}
\section{Quoted strings}\label{s:quoted-strings}
(Introduced in OCaml 4.02)
@ -1810,8 +1874,17 @@ types).
As a side-effect of this generativity, one is allowed to unpack
first-class modules in the body of generative functors.
\section{Extension operators} \label{s:ext-ops}
(Introduced in Ocaml 4.02.2)
\section{Extension-only syntax}
(Introduced in OCaml 4.02.2, extended in 4.03)
Some syntactic constructions are accepted during parsing and rejected
during type checking. These syntactic constructions can therefore not
be used directly in vanilla OCaml. However, "-ppx" rewriters and other
external tools can exploit this parser leniency to extend the language
with these new syntactic constructions by rewriting them to
vanilla constructions.
\subsection{Extension operators} \label{s:ext-ops}
(Introduced in OCaml 4.02.2)
\begin{syntax}
infix-symbol:
...
@ -1820,11 +1893,37 @@ infix-symbol:
\end{syntax}
Operator names starting with a "#" character and containing more than
one "#" character in their name are accepted during parsing and
rejected during type-checking. These operators can therefore not be
used directly in vanilla Ocaml. However, "-ppx" rewriters and other
external tools can use this parser leniency to extend the language
with new extension specific "#"-operators.
one "#" character are reserved for extensions.
\subsection{Extension literals}
(Introduced in OCaml 4.03)
\begin{syntax}
float-literal:
...
| ["-"] ("0"\ldots"9") { "0"\ldots"9"||"_" } ["." { "0"\ldots"9"||"_" }]
[("e"||"E") ["+"||"-"] ("0"\ldots"9") { "0"\ldots"9"||"_" }]
["g"\ldots"z"||"G"\ldots"Z"]
| ["-"] ("0x"||"0X")
("0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f")
{ "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }\\
["." { "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }
[("p"||"P") ["+"||"-"] ("0"\ldots"9") { "0"\ldots"9"||"_" }]
["g"\ldots"z"||"G"\ldots"Z"]
;
int-literal:
...
| ["-"] ("0"\ldots"9") { "0"\ldots"9" || "_" }["g"\ldots"z"||"G"\ldots"Z"]
| ["-"] ("0x"||"0X") ("0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f")
{ "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }
["g"\ldots"z"||"G"\ldots"Z"]
| ["-"] ("0o"||"0O") ("0"\ldots"7") { "0"\ldots"7"||"_" }
["g"\ldots"z"||"G"\ldots"Z"]
| ["-"] ("0b"||"0B") ("0"\ldots"1") { "0"\ldots"1"||"_" }
["g"\ldots"z"||"G"\ldots"Z"]
;
\end{syntax}
Int and float literals followed by an one-letter identifier in the
range @["g".."z"||"G".."Z"]@ are extension-only literals.
\section{Inline records}
(Introduced in OCaml 4.03)

2
manual/manual/refman/lex.etex
View File

@ -80,7 +80,7 @@ float-literal:
[("e"||"E") ["+"||"-"] ("0"\ldots"9") { "0"\ldots"9"||"_" }]
| ["-"] ("0x"||"0X")
("0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f")
{ "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }
{ "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }\\
["." { "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }
[("p"||"P") ["+"||"-"] ("0"\ldots"9") { "0"\ldots"9"||"_" }]
\end{syntax}

4
manual/manual/tutorials/coreexamples.etex
View File

@ -430,8 +430,8 @@ let rec deriv exp dv =
deriv (Quot(Const 1.0, Var "x")) "x";;
\end{caml_example}
\section{Pretty-printing and parsing}
\pdfsection{Pretty-printing and parsing}
\section{Pretty-printing}
\pdfsection{Pretty-printing}
As shown in the examples above, the internal representation (also
called {\em abstract syntax\/}) of expressions quickly becomes hard to

165
middle_end/alias_analysis.ml Normal file
View File

@ -0,0 +1,165 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 allocation_point =
| Symbol of Symbol.t
| Variable of Variable.t
type allocated_const =
| Normal of Allocated_const.t
| Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list
| Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t
type constant_defining_value =
| Allocated_const of allocated_const
| Block of Tag.t * Variable.t list
| Set_of_closures of Flambda.set_of_closures
| Project_closure of Flambda.project_closure
| Move_within_set_of_closures of Flambda.move_within_set_of_closures
| Project_var of Flambda.project_var
| Field of Variable.t * int
| Symbol_field of Symbol.t * int
| Const of Flambda.const
| Symbol of Symbol.t
| Variable of Variable.t
type initialize_symbol_field = Variable.t option
type definitions = {
variable : constant_defining_value Variable.Tbl.t;
initialize_symbol : initialize_symbol_field list Symbol.Tbl.t;
symbol : Flambda.constant_defining_value Symbol.Tbl.t;
}
let print_constant_defining_value ppf = function
| Allocated_const (Normal const) -> Allocated_const.print ppf const
| Allocated_const (Array (_, _, vars)) ->
Format.fprintf ppf "[| %a |]"
(Format.pp_print_list Variable.print) vars
| Allocated_const (Duplicate_array (_, _, var)) ->
Format.fprintf ppf "dup_array(%a)" Variable.print var
| Block (tag, vars) ->
Format.fprintf ppf "[|%a: %a|]"
Tag.print tag
(Format.pp_print_list Variable.print) vars
| Set_of_closures set -> Flambda.print_set_of_closures ppf set
| Project_closure project -> Flambda.print_project_closure ppf project
| Move_within_set_of_closures move ->
Flambda.print_move_within_set_of_closures ppf move
| Project_var project -> Flambda.print_project_var ppf project
| Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field
| Symbol_field (sym, field) ->
Format.fprintf ppf "%a.(%d)" Symbol.print sym field
| Const const -> Flambda.print_const ppf const
| Symbol symbol -> Symbol.print ppf symbol
| Variable var -> Variable.print ppf var
let rec resolve_definition
(definitions: definitions)
(var: Variable.t)
(def: constant_defining_value)
~the_dead_constant : allocation_point =
match def with
| Allocated_const _
| Block _
| Set_of_closures _
| Project_closure _
| Const _
| Move_within_set_of_closures _ ->
Variable var
| Project_var {var} ->
fetch_variable definitions (Var_within_closure.unwrap var)
~the_dead_constant
| Variable v ->
fetch_variable definitions v
~the_dead_constant
| Symbol sym -> Symbol sym
| Field (v, n) ->
begin match fetch_variable definitions v ~the_dead_constant with
| Symbol s ->
fetch_symbol_field definitions s n ~the_dead_constant
| Variable v ->
fetch_variable_field definitions v n ~the_dead_constant
end
| Symbol_field (symbol, field) ->
fetch_symbol_field definitions symbol field ~the_dead_constant
and fetch_variable
(definitions: definitions)
(var: Variable.t)
~the_dead_constant : allocation_point =
match Variable.Tbl.find definitions.variable var with
| exception Not_found -> Variable var
| def -> resolve_definition definitions var def ~the_dead_constant
and fetch_variable_field
(definitions: definitions)
(var: Variable.t)
(field: int)
~the_dead_constant : allocation_point =
match Variable.Tbl.find definitions.variable var with
| Block (_, fields) ->
begin match List.nth fields field with
| exception Not_found -> Symbol the_dead_constant
| v -> fetch_variable definitions v ~the_dead_constant
end
| exception Not_found ->
Misc.fatal_errorf "No definition for field access to %a" Variable.print var
| Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ ->
(* Must have been resolved *)
assert false
| Const _ | Allocated_const _
| Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ ->
Symbol the_dead_constant
and fetch_symbol_field
(definitions: definitions)
(sym: Symbol.t)
(field: int)
~the_dead_constant : allocation_point =
match Symbol.Tbl.find definitions.symbol sym with
| Block (_, fields) ->
begin match List.nth fields field with
| exception Not_found -> Symbol the_dead_constant
| Symbol s -> Symbol s
| Const _ -> Symbol sym
end
| exception Not_found ->
begin match Symbol.Tbl.find definitions.initialize_symbol sym with
| fields ->
begin match List.nth fields field with
| None ->
Misc.fatal_errorf "constant field access to an inconstant %a"
Symbol.print sym
| Some v ->
fetch_variable definitions v ~the_dead_constant
end
| exception Not_found ->
Misc.fatal_errorf "No definition for field access to %a"
Symbol.print sym
end
| Allocated_const _ | Set_of_closures _ | Project_closure _ ->
Symbol the_dead_constant
let run variable initialize_symbol symbol ~the_dead_constant =
let definitions = { variable; initialize_symbol; symbol; } in
Variable.Tbl.fold (fun var definition result ->
let definition =
resolve_definition definitions var definition ~the_dead_constant
in
Variable.Map.add var definition result)
definitions.variable
Variable.Map.empty

61
middle_end/alias_analysis.mli Normal file
View File

@ -0,0 +1,61 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 allocation_point =
| Symbol of Symbol.t
| Variable of Variable.t
type allocated_const =
| Normal of Allocated_const.t
| Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list
| Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t
type constant_defining_value =
| Allocated_const of allocated_const
| Block of Tag.t * Variable.t list
| Set_of_closures of Flambda.set_of_closures
| Project_closure of Flambda.project_closure
| Move_within_set_of_closures of Flambda.move_within_set_of_closures
| Project_var of Flambda.project_var
| Field of Variable.t * int
| Symbol_field of Symbol.t * int
| Const of Flambda.const
| Symbol of Symbol.t
| Variable of Variable.t
type initialize_symbol_field = Variable.t option
(** Simple alias analysis working over information about which
symbols have been assigned to variables; and which constants have
been assigned to symbols. The return value gives the assignment
of the defining values of constants to variables.
Also see comments for [Lift_constants], whose input feeds this
pass.
Variables found to be ill-typed accesses to other constants, for
example arising from dead code, will be pointed at [the_dead_constant].
*)
val run
: constant_defining_value Variable.Tbl.t
-> initialize_symbol_field list Symbol.Tbl.t
-> Flambda.constant_defining_value Symbol.Tbl.t
-> the_dead_constant:Symbol.t
-> allocation_point Variable.Map.t
val print_constant_defining_value
: Format.formatter
-> constant_defining_value
-> unit

83
middle_end/allocated_const.ml Normal file
View File

@ -0,0 +1,83 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
type t =
| Float of float
| Int32 of int32
| Int64 of int64
| Nativeint of nativeint
| Float_array of float list
| Immutable_float_array of float list
| String of string
| Immutable_string of string
let compare (x : t) (y : t) =
let compare_floats x1 x2 =
(* It is important to compare the bit patterns here, so as not to
be subject to bugs such as GPR#295. *)
Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
in
let rec compare_float_lists l1 l2 =
match l1, l2 with
| [], [] -> 0
| [], _::_ -> -1
| _::_, [] -> 1
| h1::t1, h2::t2 ->
let c = compare_floats h1 h2 in
if c <> 0 then c else compare_float_lists t1 t2
in
match x, y with
| Float x, Float y -> compare_floats x y
| Int32 x, Int32 y -> compare x y
| Int64 x, Int64 y -> compare x y
| Nativeint x, Nativeint y -> compare x y
| Float_array x, Float_array y -> compare_float_lists x y
| Immutable_float_array x, Immutable_float_array y -> compare_float_lists x y
| String x, String y -> compare x y
| Immutable_string x, Immutable_string y -> compare x y
| Float _, _ -> -1
| _, Float _ -> 1
| Int32 _, _ -> -1
| _, Int32 _ -> 1
| Int64 _, _ -> -1
| _, Int64 _ -> 1
| Nativeint _, _ -> -1
| _, Nativeint _ -> 1
| Float_array _, _ -> -1
| _, Float_array _ -> 1
| Immutable_float_array _, _ -> -1
| _, Immutable_float_array _ -> 1
| String _, _ -> -1
| _, String _ -> 1
let print ppf (t : t) =
let fprintf = Format.fprintf in
let floats ppf fl =
List.iter (fun f -> fprintf ppf "@ %f" f) fl
in
match t with
| String s -> fprintf ppf "%S" s
| Immutable_string s -> fprintf ppf "#%S" s
| Int32 n -> fprintf ppf "%lil" n
| Int64 n -> fprintf ppf "%LiL" n
| Nativeint n -> fprintf ppf "%nin" n
| Float f -> fprintf ppf "%f" f
| Float_array [] -> fprintf ppf "[| |]"
| Float_array (f1 :: fl) ->
fprintf ppf "@[<1>[|@[%f%a@]|]@]" f1 floats fl
| Immutable_float_array [] -> fprintf ppf "[|# |]"
| Immutable_float_array (f1 :: fl) ->
fprintf ppf "@[<1>[|# @[%f%a@]|]@]" f1 floats fl

34
middle_end/allocated_const.mli Normal file
View File

@ -0,0 +1,34 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Constants that are always allocated (possibly statically). Blocks
are not included here since they are always encoded using
[Prim (Pmakeblock, ...)]. *)
type t =
| Float of float
| Int32 of int32
| Int64 of int64
| Nativeint of nativeint
(* CR-someday mshinwell: consider using "float array" *)
| Float_array of float list
| Immutable_float_array of float list
| String of string
| Immutable_string of string
val compare : t -> t -> int
val print : Format.formatter -> t -> unit

220
middle_end/augment_closures.ml Normal file
View File

@ -0,0 +1,220 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
module A = Simple_value_approx
module E = Inline_and_simplify_aux.Env
type closures_in_free_vars =
{
new_var : Variable.t;
closure_id : Closure_id.t;
outside_var : Variable.t;
}
type block_in_free_vars =
{
new_var : Variable.t;
outside_var : Variable.t;
}
module Closure_field =
Identifiable.Make (Identifiable.Pair (Variable) (Var_within_closure))
module Block_field =
Identifiable.Make (Identifiable.Pair (Variable) (Numbers.Int))
let freshened_var env v =
Freshening.apply_variable (E.freshening env) v
let closures_in_variables ~env map acc =
Variable.Map.fold (fun inside_var outside_var acc ->
let approx = E.find_exn env (freshened_var env outside_var) in
match A.check_approx_for_closure approx with
| Ok (value_closure, _approx_var, _approx_symbol,
value_set_of_closures) ->
Var_within_closure.Map.fold (fun bound_var _ (closure_acc, block_acc) ->
let new_var =
Variable.create (Var_within_closure.unique_name bound_var)
in
let closure_acc =
Closure_field.Map.add (inside_var, bound_var)
{ new_var; closure_id = value_closure.closure_id; outside_var }
closure_acc
in
closure_acc, block_acc)
value_set_of_closures.bound_vars acc
| Wrong ->
match A.check_approx_for_block approx with
| Wrong ->
acc (* Ignore free_vars that aren't closures or blocks. *)
| Ok (_tag, fields) ->
let closure_acc, block_acc = acc in
let block_acc = ref block_acc in
Array.iteri (fun i approx ->
(* CR-soon pchambart: should we restrict only to cases
when the field is aliased to a variable outside
of the closure (i.e. when we can certainly remove
the allocation of the block) ?
Note that this may prevent cases with imbricated
closures from benefiting from this transformations.
mshinwell: What word was "imbricated" supposed to be?
*)
match approx.A.var with
| Some v when E.mem env v ->
let new_var =
Variable.create
(Variable.unique_name inside_var ^ "_field_" ^ string_of_int i)
in
block_acc :=
Block_field.Map.add (inside_var, i) { new_var; outside_var } !block_acc
| Some _ ->
()
| _ -> ())
fields;
closure_acc, !block_acc)
map
acc
let rewrite_set_of_closures
~env
~(set_of_closures:Flambda.set_of_closures) =
let elts_in_free_vars =
closures_in_variables ~env
set_of_closures.free_vars
(Closure_field.Map.empty, Block_field.Map.empty)
in
let elts_in_free_vars_and_specialised_args =
closures_in_variables ~env
set_of_closures.specialised_args
elts_in_free_vars
in
let closures_in_free_vars,
block_in_free_vars =
elts_in_free_vars_and_specialised_args
in
if Closure_field.Map.is_empty closures_in_free_vars
&& Block_field.Map.is_empty block_in_free_vars
then
set_of_closures, Variable.Map.empty, Variable.Map.empty
else
let used_new_vars = Variable.Tbl.create 42 in
let rewrite_function_decl
(function_decl:Flambda.function_declaration) =
let body =
Flambda_iterators.map_toplevel_project_var_to_expr_opt
~f:(fun project_var ->
match
Closure_field.Map.find
(project_var.closure, project_var.var)
closures_in_free_vars
with
| exception Not_found ->
None
| { new_var } ->
Variable.Tbl.add used_new_vars new_var ();
Some (Flambda.Var new_var))
function_decl.body
in
let body =
Flambda_iterators.map_toplevel_named (function
| (Prim (Pfield i, [v], _)) when
Block_field.Map.mem (v, i) block_in_free_vars ->
let { new_var } = Block_field.Map.find (v, i) block_in_free_vars in
Variable.Tbl.add used_new_vars new_var ();
Expr (Var new_var)
| named ->
named)
body
in
Flambda.create_function_declaration
~body
~inline:function_decl.inline
~params:function_decl.params
~stub:function_decl.stub
~dbg:function_decl.dbg
~is_a_functor:function_decl.is_a_functor
in
let funs =
Variable.Map.map
rewrite_function_decl
set_of_closures.function_decls.funs
in
let function_decls =
Flambda.update_function_declarations ~funs
set_of_closures.function_decls
in
let free_vars, add_closures =
Closure_field.Map.fold
(fun (_var, field) { new_var; closure_id; outside_var } (free_vars, add_closures) ->
let intermediate_var =
Variable.rename new_var
in
if Variable.Tbl.mem used_new_vars new_var then
Variable.Map.add new_var intermediate_var free_vars,
Variable.Map.add intermediate_var
(Flambda.Project_var { Flambda.closure = outside_var; closure_id; var = field })
add_closures
else
free_vars, add_closures)
closures_in_free_vars
(set_of_closures.free_vars,
Variable.Map.empty)
in
let free_vars, add_blocks =
Block_field.Map.fold
(fun (_var, field) { new_var; outside_var } (free_vars, add_blocks) ->
let intermediate_var =
Variable.rename new_var
in
if Variable.Tbl.mem used_new_vars new_var then
Variable.Map.add new_var intermediate_var free_vars,
Variable.Map.add intermediate_var
(Flambda.Prim (Pfield field, [outside_var], Debuginfo.none))
add_blocks
else
free_vars, add_blocks)
block_in_free_vars
(free_vars,
Variable.Map.empty)
in
Flambda.create_set_of_closures
~function_decls
~free_vars
~specialised_args:set_of_closures.specialised_args,
add_closures, add_blocks
let run ~env ~(set_of_closures:Flambda.set_of_closures) : Flambda.t option =
if !Clflags.classic_inlining then None
else
let set_of_closures, add_closures, add_blocks =
rewrite_set_of_closures
~env ~set_of_closures
in
if Variable.Map.is_empty add_closures &&
Variable.Map.is_empty add_blocks then
None
else
let expr =
Variable.Map.fold Flambda.create_let
add_closures
(Flambda_utils.name_expr (Set_of_closures set_of_closures)
~name:"augment_closure")
in
let expr =
Variable.Map.fold Flambda.create_let
add_blocks expr
in
Some expr

21
middle_end/augment_closures.mli Normal file
View File

@ -0,0 +1,21 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
val run :
env:Inline_and_simplify_aux.Env.t ->
set_of_closures:Flambda.set_of_closures ->
Flambda.t option

45
middle_end/backend_intf.mli Normal file
View File

@ -0,0 +1,45 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Knowledge that the middle end needs about the backend. *)
module type S = sig
(** Compute the symbol for the given identifier. *)
val symbol_for_global' : (Ident.t -> Symbol.t)
(** If the given approximation is that of a symbol (Value_symbol) or an
external (Value_extern), attempt to find a more informative
approximation from a previously-written compilation artifact. In the
native code backend, for example, this might consult a .cmx file. *)
val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t
val import_symbol : Symbol.t -> Simple_value_approx.t
val closure_symbol : Closure_id.t -> Symbol.t
(** The natural size of an integer on the target architecture
(cf. [Arch.size_int] in the native code backend). *)
val size_int : int
(** [true] iff the target architecture is big endian. *)
val big_endian : bool
(** The maximum number of arguments that is is reasonable for a function
to have. This should be fewer than the threshold that causes non-self
tail call optimization to be inhibited (in particular, if it would
entail passing arguments on the stack; see [Selectgen]). *)
val max_sensible_number_of_arguments : int
end

22
middle_end/base_types/closure_element.ml 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. *)
(* *)
(**************************************************************************)
include Variable
let wrap t = t
let unwrap t = t
let wrap_map t = t

29
middle_end/base_types/closure_element.mli Normal file
View File

@ -0,0 +1,29 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
include Identifiable.S
val wrap : Variable.t -> t
val unwrap : t -> Variable.t
val wrap_map : 'a Variable.Map.t -> 'a Map.t
val in_compilation_unit : t -> Compilation_unit.t -> bool
val get_compilation_unit : t -> Compilation_unit.t
val unique_name : t -> string
val output_full : out_channel -> t -> unit

17
middle_end/base_types/closure_id.ml Normal file
View File

@ -0,0 +1,17 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
include Closure_element

24
middle_end/base_types/closure_id.mli Normal file
View File

@ -0,0 +1,24 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** CR-someday lwhite: "Closure_id" is quite a generic name. I wonder wether something
like "Closure_label" would better capture that it is the label of a projection. *)
(** An identifier, unique across the whole program (not just one compilation
unit), that identifies a closure within a particular set of closures
(viz. [Project_closure]). *)
include module type of Closure_element

71
middle_end/base_types/compilation_unit.ml Normal file
View File

@ -0,0 +1,71 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
type t = {
id : Ident.t;
linkage_name : Linkage_name.t;
hash : int;
}
let string_for_printing t = Ident.name t.id
include Identifiable.Make (struct
type nonrec t = t
(* Multiple units can have the same [id] if they come from different packs.
To distinguish these we also keep the linkage name, which contains the
name of the pack. *)
let compare v1 v2 =
if v1 == v2 then 0
else
let c = compare v1.hash v2.hash in
if c = 0 then
let v1_id = Ident.name v1.id in
let v2_id = Ident.name v2.id in
let c = String.compare v1_id v2_id in
if c = 0 then
Linkage_name.compare v1.linkage_name v2.linkage_name
else
c
else c
let equal x y =
if x == y then true
else compare x y = 0
let print ppf t = Format.pp_print_string ppf (string_for_printing t)
let output oc x = output_string oc (Ident.name x.id)
let hash x = x.hash
end)
let create (id : Ident.t) linkage_name =
if not (Ident.persistent id) then begin
Misc.fatal_error "Compilation_unit.create with non-persistent Ident.t"
end;
{ id; linkage_name; hash = Hashtbl.hash id.name }
let get_persistent_ident cu = cu.id
let get_linkage_name cu = cu.linkage_name
let current = ref None
let set_current t = current := Some t
let get_current () = !current
let get_current_exn () =
match !current with
| Some current -> current
| None -> Misc.fatal_error "Compilation_unit.get_current_exn"
let get_current_id_exn () = get_persistent_ident (get_current_exn ())

31
middle_end/base_types/compilation_unit.mli Normal file
View File

@ -0,0 +1,31 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
include Identifiable.S
(* The [Ident.t] must be persistent. This function raises an exception
if that is not the case. *)
val create : Ident.t -> Linkage_name.t -> t
val get_persistent_ident : t -> Ident.t
val get_linkage_name : t -> Linkage_name.t
val set_current : t -> unit
val get_current : unit -> t option
val get_current_exn : unit -> t
val get_current_id_exn : unit -> Ident.t
val string_for_printing : t -> string

26
middle_end/base_types/export_id.ml Normal file
View File

@ -0,0 +1,26 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
module Id : Id_types.Id = Id_types.Id (struct end)
module Unit_id = Id_types.UnitId (Id) (Compilation_unit)
type t = Unit_id.t
include Identifiable.Make (Unit_id)
let create = Unit_id.create
let get_compilation_unit = Unit_id.unit
let name = Unit_id.name

26
middle_end/base_types/export_id.mli Normal file
View File

@ -0,0 +1,26 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(* Keys representing value descriptions that may be written into
intermediate files and loaded by a dependent compilation unit.
These keys are used to ensure maximal sharing of value descriptions,
which may be substantial. *)
include Identifiable.S
val create : ?name:string -> Compilation_unit.t -> t
val name : t -> string option
val get_compilation_unit : t -> Compilation_unit.t

90
middle_end/base_types/id_types.ml Normal file
View File

@ -0,0 +1,90 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
module type BaseId = sig
type t
val equal : t -> t -> bool
val compare : t -> t -> int
val hash : t -> int
val name : t -> string option
val to_string : t -> string
val output : out_channel -> t -> unit
val print : Format.formatter -> t -> unit
end
module type Id = sig
include BaseId
val create : ?name:string -> unit -> t
end
module type UnitId = sig
module Compilation_unit : Identifiable.Thing
include BaseId
val create : ?name:string -> Compilation_unit.t -> t
val unit : t -> Compilation_unit.t
end
module Id(E:sig end) : Id = struct
type t = int * string
let empty_string = ""
let create = let r = ref 0 in
fun ?(name=empty_string) () -> incr r; !r, name
let equal (t1,_) (t2,_) = (t1:int) = t2
let compare (t1,_) (t2,_) = t1 - t2
let hash (t,_) = t
let name (_,name) =
if name == empty_string
then None
else Some name
let to_string (t,name) =
if name == empty_string
then string_of_int t
else Printf.sprintf "%s_%i" name t
let output fd t = output_string fd (to_string t)
let print ppf v = Format.pp_print_string ppf (to_string v)
end
module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) :
UnitId with module Compilation_unit := Compilation_unit = struct
type t = {
id : Innerid.t;
unit : Compilation_unit.t;
}
let compare x y =
let c = Innerid.compare x.id y.id in
if c <> 0
then c
else Compilation_unit.compare x.unit y.unit
let output oc x =
Printf.fprintf oc "%a.%a"
Compilation_unit.output x.unit
Innerid.output x.id
let print ppf x =
Format.fprintf ppf "%a.%a"
Compilation_unit.print x.unit
Innerid.print x.id
let hash off = Hashtbl.hash off
let equal o1 o2 = compare o1 o2 = 0
let name o = Innerid.name o.id
let to_string x =
Format.asprintf "%a.%a"
Compilation_unit.print x.unit
Innerid.print x.id
let create ?name unit =
let id = Innerid.create ?name () in
{ id; unit }
let unit x = x.unit
end

57
middle_end/base_types/id_types.mli Normal file
View File

@ -0,0 +1,57 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(* CR-soon mshinwell: This module should be removed. *)
(** Generic identifier type *)
module type BaseId =
sig
type t
val equal : t -> t -> bool
val compare : t -> t -> int
val hash : t -> int
val name : t -> string option
val to_string : t -> string
val output : out_channel -> t -> unit
val print : Format.formatter -> t -> unit
end
module type Id =
sig
include BaseId
val create : ?name:string -> unit -> t
end
(** Fully qualified identifiers *)
module type UnitId =
sig
module Compilation_unit : Identifiable.Thing
include BaseId
val create : ?name:string -> Compilation_unit.t -> t
val unit : t -> Compilation_unit.t
end
(** If applied generatively, i.e. [Id(struct end)], creates a new type
of identifiers. *)
module Id : functor (E : sig end) -> Id
module UnitId :
functor (Id : Id) ->
functor (Compilation_unit : Identifiable.Thing) ->
UnitId with module Compilation_unit := Compilation_unit

27
middle_end/base_types/linkage_name.ml Normal file
View File

@ -0,0 +1,27 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
type t = string
include Identifiable.Make (struct
include String
let hash = Hashtbl.hash
let print ppf t = Format.pp_print_string ppf t
let output chan t = output_string chan t
end)
let create t = t
let to_string t = t

20
middle_end/base_types/linkage_name.mli Normal file
View File

@ -0,0 +1,20 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
include Identifiable.S
val create : string -> t
val to_string : t -> string

89
middle_end/base_types/mutable_variable.ml Normal file
View File

@ -0,0 +1,89 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
type t = {
compilation_unit : Compilation_unit.t;
ident : Ident.t;
}
include Identifiable.Make (struct
type nonrec t = t
let compare v1 v2 =
let c = Ident.compare v1.ident v2.ident in
if c = 0
then Compilation_unit.compare v1.compilation_unit v2.compilation_unit
else c
let output c v = Ident.output c v.ident
let hash v = Ident.hash v.ident
let equal v1 v2 =
Ident.same v1.ident v2.ident &&
Compilation_unit.equal v1.compilation_unit v2.compilation_unit
let print ppf v =
Format.fprintf ppf "%a.%a"
Compilation_unit.print v.compilation_unit
Ident.print v.ident
end)
let create ?current_compilation_unit name =
let compilation_unit =
match current_compilation_unit with
| Some compilation_unit -> compilation_unit
| None -> Compilation_unit.get_current_exn ()
in
{ compilation_unit;
ident = Ident.create name;
}
let of_ident ident = create (Ident.name ident)
let unique_ident t =
{ t.ident with
name =
Format.asprintf "%a_%s"
Compilation_unit.print t.compilation_unit
t.ident.name;
}
let rename ?current_compilation_unit ?append t =
let compilation_unit =
match current_compilation_unit with
| Some compilation_unit -> compilation_unit
| None -> Compilation_unit.get_current_exn ()
in
let ident =
match append with
| None -> Ident.rename t.ident
| Some s -> Ident.create (t.ident.Ident.name ^ s)
in
{ compilation_unit = compilation_unit;
ident;
}
let freshen t =
rename t ~current_compilation_unit:(Compilation_unit.get_current_exn ())
let in_compilation_unit t cu =
Compilation_unit.equal t.compilation_unit cu
let output_full c t =
Compilation_unit.output c t.compilation_unit;
Printf.fprintf c ".";
Ident.output c t.ident

35
middle_end/base_types/mutable_variable.mli Normal file
View File

@ -0,0 +1,35 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
include Identifiable.S
val create : ?current_compilation_unit:Compilation_unit.t -> string -> t
val of_ident : Ident.t -> t
(** For [Flambda_to_clambda] only. *)
val unique_ident : t -> Ident.t
val freshen : t -> t
val rename
: ?current_compilation_unit:Compilation_unit.t
-> ?append:string
-> t
-> t
val in_compilation_unit : t -> Compilation_unit.t -> bool
val output_full : out_channel -> t -> unit

25
middle_end/base_types/set_of_closures_id.ml Normal file
View File

@ -0,0 +1,25 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
module Id : Id_types.Id = Id_types.Id (struct end)
module Unit_id = Id_types.UnitId (Id) (Compilation_unit)
type t = Unit_id.t
include Identifiable.Make (Unit_id)
let create = Unit_id.create
let get_compilation_unit = Unit_id.unit

23
middle_end/base_types/set_of_closures_id.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. *)
(* *)
(**************************************************************************)
(** An identifier, unique across the whole program, that identifies a set
of a closures (viz. [Set_of_closures]). *)
include Identifiable.S
val create : ?name:string -> Compilation_unit.t -> t
val get_compilation_unit : t -> Compilation_unit.t

20
middle_end/base_types/static_exception.ml Normal file
View File

@ -0,0 +1,20 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
include Numbers.Int
let create () = Lambda.next_raise_count ()
let to_int t = t

24
middle_end/base_types/static_exception.mli Normal file
View File

@ -0,0 +1,24 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** An identifier that is used to label static exceptions. Its
uniqueness properties are unspecified. *)
include Identifiable.S
val create : unit -> t
val to_int : t -> int

75
middle_end/base_types/symbol.ml Normal file
View File

@ -0,0 +1,75 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
type t = {
compilation_unit : Compilation_unit.t;
label : Linkage_name.t;
hash : int;
}
include Identifiable.Make (struct
type nonrec t = t
let compare t1 t2 =
(* Linkage names are unique across a whole project, so just comparing
those is sufficient. *)
if t1 == t2 then 0
else
let c = compare t1.hash t2.hash in
if c <> 0 then c
else Linkage_name.compare t1.label t2.label
let equal x y =
if x == y then true
else compare x y = 0
let output chan t = Linkage_name.output chan t.label
let hash t = t.hash
let print ppf t =
Compilation_unit.print ppf t.compilation_unit;
Format.pp_print_string ppf ".";
Linkage_name.print ppf t.label
end)
let create compilation_unit label =
let unit_linkage_name =
Linkage_name.to_string
(Compilation_unit.get_linkage_name compilation_unit)
in
let label =
Linkage_name.create (unit_linkage_name ^ "__" ^ (Linkage_name.to_string label))
in
let hash = Linkage_name.hash label in
{ compilation_unit; label; hash; }
let unsafe_create compilation_unit label =
let hash = Linkage_name.hash label in
{ compilation_unit; label; hash; }
let import_for_pack ~pack:compilation_unit symbol =
let hash = Linkage_name.hash symbol.label in
{ compilation_unit; label = symbol.label; hash; }
let compilation_unit t = t.compilation_unit
let label t = t.label
let print_opt ppf = function
| None -> Format.fprintf ppf "<no symbol>"
| Some t -> print ppf t
let compare_lists l1 l2 = Misc.compare_lists compare l1 l2

41
middle_end/base_types/symbol.mli Normal file
View File

@ -0,0 +1,41 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** A symbol identifies a constant provided by either:
- another compilation unit; or
- a top-level module.
* [sym_unit] is the compilation unit containing the value.
* [sym_label] is the linkage name of the variable.
The label must be globally unique: two compilation units linked in the
same program must not share labels. *)
include Identifiable.S
val create : Compilation_unit.t -> Linkage_name.t -> t
(* Create the symbol without prefixing with the compilation unit.
Used for predefined exceptions *)
val unsafe_create : Compilation_unit.t -> Linkage_name.t -> t
val import_for_pack : pack:Compilation_unit.t -> t -> t
val compilation_unit : t -> Compilation_unit.t
val label : t -> Linkage_name.t
val print_opt : Format.formatter -> t option -> unit
val compare_lists : t list -> t list -> int

30
middle_end/base_types/tag.ml Normal file
View File

@ -0,0 +1,30 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
type t = int
include Identifiable.Make (Numbers.Int)
let create_exn tag =
if tag < 0 || tag > 255 then
Misc.fatal_error (Printf.sprintf "Tag.create_exn %d" tag)
else
tag
let to_int t = t
let zero = 0
let object_tag = Obj.object_tag

25
middle_end/base_types/tag.mli Normal file
View File

@ -0,0 +1,25 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Tags on runtime boxed values. *)
include Identifiable.S
val create_exn : int -> t
val to_int : t -> int
val zero : t
val object_tag : t

17
middle_end/base_types/var_within_closure.ml Normal file
View File

@ -0,0 +1,17 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
include Closure_element

22
middle_end/base_types/var_within_closure.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. *)
(* *)
(**************************************************************************)
(** An identifier, unique across the whole program, that identifies a
particular variable within a particular closure. Only
[Project_var], and not [Var], nodes are tagged with these
identifiers. *)
include module type of Closure_element

121
middle_end/base_types/variable.ml Normal file
View File

@ -0,0 +1,121 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
type t = {
compilation_unit : Compilation_unit.t;
name : string;
name_stamp : int;
(** [name_stamp]s are unique within any given compilation unit. *)
}
include Identifiable.Make (struct
type nonrec t = t
let compare t1 t2 =
if t1 == t2 then 0
else
let c = t1.name_stamp - t2.name_stamp in
if c <> 0 then c
else Compilation_unit.compare t1.compilation_unit t2.compilation_unit
let equal t1 t2 =
if t1 == t2 then true
else
t1.name_stamp = t2.name_stamp
&& Compilation_unit.equal t1.compilation_unit t2.compilation_unit
let output chan t =
output_string chan t.name;
output_string chan "_";
output_string chan (string_of_int t.name_stamp)
let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit)
let print ppf t =
if Compilation_unit.equal t.compilation_unit
(Compilation_unit.get_current_exn ())
then begin
Format.fprintf ppf "%s/%d"
t.name t.name_stamp
end else begin
Format.fprintf ppf "%a.%s/%d"
Compilation_unit.print t.compilation_unit
t.name t.name_stamp
end
end)
let previous_name_stamp = ref (-1)
let create ?current_compilation_unit name =
let compilation_unit =
match current_compilation_unit with
| Some compilation_unit -> compilation_unit
| None -> Compilation_unit.get_current_exn ()
in
let name_stamp =
incr previous_name_stamp;
!previous_name_stamp
in
{ compilation_unit;
name;
name_stamp;
}
let create_with_same_name_as_ident ident = create (Ident.name ident)
let clambda_name t =
(Compilation_unit.string_for_printing t.compilation_unit) ^ "_" ^ t.name
let rename ?current_compilation_unit ?append t =
let current_compilation_unit =
match current_compilation_unit with
| Some compilation_unit -> compilation_unit
| None -> Compilation_unit.get_current_exn ()
in
let name =
match append with
| None -> t.name
| Some s -> t.name ^ s
in
create ~current_compilation_unit name
let in_compilation_unit t cu =
Compilation_unit.equal cu t.compilation_unit
let get_compilation_unit t = t.compilation_unit
let unique_name t =
t.name ^ "_" ^ (string_of_int t.name_stamp)
let print_list ppf ts =
List.iter (fun t -> Format.fprintf ppf "@ %a" print t) ts
let debug_when_stamp_matches t ~stamp ~f =
if t.name_stamp = stamp then f ()
let print_opt ppf = function
| None -> Format.fprintf ppf "<no var>"
| Some t -> print ppf t
type pair = t * t
module Pair = Identifiable.Make (Identifiable.Pair (T) (T))
let compare_lists l1 l2 = Misc.compare_lists compare l1 l2
let output_full chan t =
Compilation_unit.output chan t.compilation_unit;
output_string chan ".";
output chan t

60
middle_end/base_types/variable.mli Normal file
View File

@ -0,0 +1,60 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** [Variable.t] is the equivalent of a non-persistent [Ident.t] in
the [Flambda] tree. It wraps an [Ident.t] together with its source
[compilation_unit]. As such, it is unique within a whole program,
not just one compilation unit.
Introducing a new type helps in tracing the source of identifiers
when debugging the inliner. It also avoids Ident renaming when
importing cmx files.
*)
include Identifiable.S
val create : ?current_compilation_unit:Compilation_unit.t -> string -> t
val create_with_same_name_as_ident : Ident.t -> t
val clambda_name : t -> string
(* CR-someday pchambart: Should we propagate Variable.t into clambda ??? *)
val rename
: ?current_compilation_unit:Compilation_unit.t
-> ?append:string
-> t
-> t
val in_compilation_unit : t -> Compilation_unit.t -> bool
val unique_name : t -> string
val get_compilation_unit : t -> Compilation_unit.t
val print_list : Format.formatter -> t list -> unit
val print_opt : Format.formatter -> t option -> unit
(** If the given variable has the given stamp, call the user-supplied
function. For debugging purposes only. *)
val debug_when_stamp_matches : t -> stamp:int -> f:(unit -> unit) -> unit
type pair = t * t
module Pair : Identifiable.S with type t := pair
val compare_lists : t list -> t list -> int
val output_full : out_channel -> t -> unit
(** Unlike [output], [output_full] includes the compilation unit. *)

603
middle_end/closure_conversion.ml Normal file
View File

@ -0,0 +1,603 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 = Closure_conversion_aux.Env
module Function_decls = Closure_conversion_aux.Function_decls
module Function_decl = Function_decls.Function_decl
module IdentSet = Lambda.IdentSet
let name_expr = Flambda_utils.name_expr
type t = {
current_unit_id : Ident.t;
symbol_for_global' : (Ident.t -> Symbol.t);
mutable imported_symbols : Symbol.Set.t;
}
(** Generate a wrapper ("stub") function that accepts a tuple argument and
calls another function with arguments extracted in the obvious
manner from the tuple. *)
let tupled_function_call_stub original_params unboxed_version
: Flambda.function_declaration =
let tuple_param =
Variable.rename ~append:"tupled_stub_param" unboxed_version
in
let params = List.map (fun p -> Variable.rename p) original_params in
let call : Flambda.t =
Apply ({
func = unboxed_version;
args = params;
(* CR-someday mshinwell for mshinwell: investigate if there is some
redundancy here (func is also unboxed_version) *)
kind = Direct (Closure_id.wrap unboxed_version);
dbg = Debuginfo.none;
inline = Default_inline;
})
in
let _, body =
List.fold_left (fun (pos, body) param ->
let lam : Flambda.named =
Prim (Pfield pos, [tuple_param], Debuginfo.none)
in
pos + 1, Flambda.create_let param lam body)
(0, call) params
in
Flambda.create_function_declaration ~params:[tuple_param]
~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline
~is_a_functor:false
(** Propagate an [Lev_after] debugging event into an adjacent Flambda node. *)
let add_debug_info (ev : Lambda.lambda_event) (flam : Flambda.t)
: Flambda.t =
match ev.lev_kind with
| Lev_after _ ->
begin match flam with
| Apply ap ->
Apply { ap with dbg = Debuginfo.from_call ev; }
| Let let_expr ->
Flambda.map_defining_expr_of_let let_expr ~f:(function
| Prim (p, args, _dinfo) ->
Prim (p, args, Debuginfo.from_call ev)
| defining_expr -> defining_expr)
| Send { kind; meth; obj; args; dbg = _; } ->
Send { kind; meth; obj; args; dbg = Debuginfo.from_call ev; }
| _ -> flam
end
| _ -> flam
let rec eliminate_const_block (const : Lambda.structured_constant)
: Lambda.lambda =
match const with
| Const_block (tag, consts) ->
Lprim (Pmakeblock (tag, Asttypes.Immutable),
List.map eliminate_const_block consts)
| Const_base _
| Const_pointer _
| Const_immstring _
| Const_float_array _ -> Lconst const
let rec close_const t env (const : Lambda.structured_constant)
: Flambda.named * string =
match const with
| Const_base (Const_int c) -> Const (Int c), "int"
| Const_base (Const_char c) -> Const (Char c), "char"
| Const_base (Const_string (s, _)) -> Allocated_const (String s), "string"
| Const_base (Const_float c) ->
Allocated_const (Float (float_of_string c)), "float"
| Const_base (Const_int32 c) -> Allocated_const (Int32 c), "int32"
| Const_base (Const_int64 c) -> Allocated_const (Int64 c), "int64"
| Const_base (Const_nativeint c) ->
Allocated_const (Nativeint c), "nativeint"
| Const_pointer c -> Const (Const_pointer c), "pointer"
| Const_immstring c -> Allocated_const (Immutable_string c), "immstring"
| Const_float_array c ->
Allocated_const (Float_array (List.map float_of_string c)), "float_array"
| Const_block _ ->
Expr (close t env (eliminate_const_block const)), "const_block"
and close t env (lam : Lambda.lambda) : Flambda.t =
match lam with
| Lvar id ->
begin match Env.find_var_exn env id with
| var -> Var var
| exception Not_found ->
match Env.find_mutable_var_exn env id with
| mut_var -> name_expr (Read_mutable mut_var) ~name:"read_mutable"
| exception Not_found ->
Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a"
Ident.print id
end
| Lconst cst ->
let cst, name = close_const t env cst in
name_expr cst ~name:("const_" ^ name)
| Llet ((Strict | Alias | StrictOpt), id, defining_expr, body) ->
let var = Variable.create_with_same_name_as_ident id in
let defining_expr = close_let_bound_expression t var env defining_expr in
let body = close t (Env.add_var env id var) body in
Flambda.create_let var defining_expr body
| Llet (Variable, id, defining_expr, body) ->
let mut_var = Mutable_variable.of_ident id in
let var = Variable.create_with_same_name_as_ident id in
let defining_expr = close_let_bound_expression t var env defining_expr in
let body = close t (Env.add_mutable_var env id mut_var) body in
Flambda.create_let var defining_expr (Let_mutable (mut_var, var, body))
| Lfunction { kind; params; body; attr; } ->
let name =
(* Name anonymous functions by their source location, if known. *)
match body with
| Levent (_, { lev_loc }) ->
Format.asprintf "anon-fn[%a]" Location.print_compact lev_loc
| _ -> "anon-fn"
in
let closure_bound_var = Variable.create name in
(* CR-soon mshinwell: some of this is now very similar to the let rec case
below *)
let set_of_closures_var = Variable.create ("set_of_closures_" ^ name) in
let set_of_closures =
let decl =
Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind
~params ~body ~inline:attr.inline ~is_a_functor:attr.is_a_functor
in
close_functions t env (Function_decls.create [decl])
in
let project_closure : Flambda.project_closure =
{ set_of_closures = set_of_closures_var;
closure_id = Closure_id.wrap closure_bound_var;
}
in
Flambda.create_let set_of_closures_var set_of_closures
(name_expr (Project_closure (project_closure))
~name:("project_closure_" ^ name))
| Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _;
ap_inlined; } ->
Lift_code.lifting_helper (close_list t env ap_args)
~evaluation_order:`Right_to_left
~name:"apply_arg"
~create_body:(fun args ->
let func = close t env ap_func in
let func_var = Variable.create "apply_funct" in
Flambda.create_let func_var (Expr func)
(Apply ({
func = func_var;
args;
kind = Indirect;
dbg = Debuginfo.from_location Dinfo_call ap_loc;
inline = ap_inlined;
})))
| Lletrec (defs, body) ->
let env =
List.fold_right (fun (id, _) env ->
Env.add_var env id (Variable.create_with_same_name_as_ident id))
defs env
in
let function_declarations =
(* Identify any bindings in the [let rec] that are functions. These
will be named after the corresponding identifier in the [let rec]. *)
List.map (function
| (let_rec_ident, Lambda.Lfunction { kind; params; body; attr; }) ->
let closure_bound_var =
Variable.create_with_same_name_as_ident let_rec_ident
in
let function_declaration =
Function_decl.create ~let_rec_ident:(Some let_rec_ident)
~closure_bound_var ~kind ~params ~body
~inline:attr.inline ~is_a_functor:attr.is_a_functor
in
Some function_declaration
| _ -> None)
defs
in
begin match Misc.some_if_all_elements_are_some function_declarations with
| Some function_declarations ->
(* When all the bindings are (syntactically) functions, we can
eliminate the [let rec] construction, instead producing a normal
[Let] that binds a set of closures containing all of the functions.
*)
(* CR-someday lwhite: This is a very syntactic criteria. Adding an
unused value to a set of recursive bindings changes how
functions are represented at runtime. *)
let name =
(* The Microsoft assembler has a 247-character limit on symbol
names, so we keep them shorter to try not to hit this. *)
if Sys.win32 then begin
match defs with
| (id, _)::_ -> (Ident.unique_name id) ^ "_let_rec"
| _ -> "let_rec"
end else begin
String.concat "_and_"
(List.map (fun (id, _) -> Ident.unique_name id) defs)
end
in
let set_of_closures_var = Variable.create name in
let set_of_closures =
close_functions t env (Function_decls.create function_declarations)
in
let body =
List.fold_left (fun body decl ->
let let_rec_ident = Function_decl.let_rec_ident decl in
let closure_bound_var = Function_decl.closure_bound_var decl in
let let_bound_var = Env.find_var env let_rec_ident in
(* Inside the body of the [let], each function is referred to by
a [Project_closure] expression, which projects from the set of
closures. *)
(Flambda.create_let let_bound_var
(Project_closure {
set_of_closures = set_of_closures_var;
closure_id = Closure_id.wrap closure_bound_var;
})
body))
(close t env body) function_declarations
in
Flambda.create_let set_of_closures_var set_of_closures body
| None ->
(* If the condition above is not satisfied, we build a [Let_rec]
expression; any functions bound by it will have their own
individual closures. *)
let defs =
List.map (fun (id, def) ->
let var = Env.find_var env id in
var, close_let_bound_expression t ~let_rec_ident:id var env def)
defs
in
Let_rec (defs, close t env body)
end
| Lsend (kind, meth, obj, args, loc) ->
let meth_var = Variable.create "meth" in
let obj_var = Variable.create "obj" in
let dbg = Debuginfo.from_location Dinfo_call loc in
Flambda.create_let meth_var (Expr (close t env meth))
(Flambda.create_let obj_var (Expr (close t env obj))
(Lift_code.lifting_helper (close_list t env args)
~evaluation_order:`Right_to_left
~name:"send_arg"
~create_body:(fun args ->
Send { kind; meth = meth_var; obj = obj_var; args; dbg; })))
| Lprim ((Pdivint | Pmodint) as prim, [arg1; arg2])
when not !Clflags.fast -> (* not -unsafe *)
let arg2 = close t env arg2 in
let arg1 = close t env arg1 in
let numerator = Variable.create "numerator" in
let denominator = Variable.create "denominator" in
let zero = Variable.create "zero" in
let is_zero = Variable.create "is_zero" in
let exn = Variable.create "division_by_zero" in
let exn_symbol =
t.symbol_for_global' Predef.ident_division_by_zero
in
t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols;
Flambda.create_let zero (Const (Int 0))
(Flambda.create_let exn (Symbol exn_symbol)
(Flambda.create_let denominator (Expr arg2)
(Flambda.create_let numerator (Expr arg1)
(Flambda.create_let is_zero
(Prim (Pintcomp Ceq, [zero; denominator], Debuginfo.none))
(If_then_else (is_zero,
name_expr (Prim (Praise Raise_regular, [exn],
Debuginfo.none))
~name:"dummy",
(* CR-someday pchambart: find the right event.
mshinwell: I briefly looked at this, and couldn't
figure it out.
lwhite: I don't think any of the existing events
are suitable. I had to add a new one for a similar
case in the array data types work.
mshinwell: deferred CR *)
(* Debuginfo.from_raise event *)
name_expr ~name:"result"
(Prim (prim, [numerator; denominator],
Debuginfo.none))))))))
| Lprim ((Pdivint | Pmodint), _) when not !Clflags.fast ->
Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments"
| Lprim (Psequor, [arg1; arg2]) ->
let arg1 = close t env arg1 in
let arg2 = close t env arg2 in
let const_true = Variable.create "const_true" in
let cond = Variable.create "cond_sequor" in
Flambda.create_let const_true (Const (Int 1))
(Flambda.create_let cond (Expr arg1)
(If_then_else (cond, Var const_true, arg2)))
| Lprim (Psequand, [arg1; arg2]) ->
let arg1 = close t env arg1 in
let arg2 = close t env arg2 in
let const_false = Variable.create "const_false" in
let cond = Variable.create "cond_sequand" in
Flambda.create_let const_false (Const (Int 0))
(Flambda.create_let cond (Expr arg1)
(If_then_else (cond, arg2, Var const_false)))
| Lprim ((Psequand | Psequor), _) ->
Misc.fatal_error "Psequand / Psequor must have exactly two arguments"
| Lprim (Pidentity, [arg]) -> close t env arg
| Lprim (Pdirapply loc, [funct; arg])
| Lprim (Prevapply loc, [arg; funct]) ->
let apply : Lambda.lambda_apply =
{ ap_func = funct;
ap_args = [arg];
ap_loc = loc;
ap_should_be_tailcall = false;
(* CR-someday lwhite: it would be nice to be able to give
inlined attributes to functions applied with the application
operators. *)
ap_inlined = Default_inline;
}
in
close t env (Lambda.Lapply apply)
| Lprim (Praise kind, [Levent (arg, event)]) ->
let arg_var = Variable.create "raise_arg" in
Flambda.create_let arg_var (Expr (close t env arg))
(name_expr
(Prim (Praise kind, [arg_var], Debuginfo.from_raise event))
~name:"raise")
| Lprim (Pfield _, [Lprim (Pgetglobal id, [])])
when Ident.same id t.current_unit_id ->
Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \
unit is forbidden upon entry to the middle end"
| Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, []); _]) ->
Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \
forbidden upon entry to the middle end"
| Lprim (Pgetglobal id, []) when Ident.is_predef_exn id ->
let symbol = t.symbol_for_global' id in
t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
name_expr (Symbol symbol) ~name:"predef_exn"
| Lprim (Pgetglobal id, []) ->
assert (not (Ident.same id t.current_unit_id));
let symbol = t.symbol_for_global' id in
t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
name_expr (Symbol symbol) ~name:"Pgetglobal"
| Lprim (p, args) ->
(* One of the important consequences of the ANF-like representation
here is that we obtain names corresponding to the components of
blocks being made (with [Pmakeblock]). This information can be used
by the simplification pass to increase the likelihood of eliminating
the allocation, since some field accesses can be tracked back to known
field values. ,*)
let name = Printlambda.string_of_primitive p in
Lift_code.lifting_helper (close_list t env args)
~evaluation_order:`Right_to_left
~name:(name ^ "_arg")
~create_body:(fun args ->
name_expr (Prim (p, args, Debuginfo.none)) ~name)
| Lswitch (arg, sw) ->
let scrutinee = Variable.create "switch" in
let aux (i, lam) = i, close t env lam in
let zero_to_n = Numbers.Int.zero_to_n in
Flambda.create_let scrutinee (Expr (close t env arg))
(Switch (scrutinee,
{ numconsts = zero_to_n (sw.sw_numconsts - 1);
consts = List.map aux sw.sw_consts;
numblocks = zero_to_n (sw.sw_numblocks - 1);
blocks = List.map aux sw.sw_blocks;
failaction = Misc.may_map (close t env) sw.sw_failaction;
}))
| Lstringswitch (arg, sw, def) ->
let scrutinee = Variable.create "string_switch" in
Flambda.create_let scrutinee (Expr (close t env arg))
(String_switch (scrutinee,
List.map (fun (s, e) -> s, close t env e) sw,
Misc.may_map (close t env) def))
| Lstaticraise (i, args) ->
Lift_code.lifting_helper (close_list t env args)
~evaluation_order:`Right_to_left
~name:"staticraise_arg"
~create_body:(fun args ->
let static_exn = Env.find_static_exception env i in
Static_raise (static_exn, args))
| Lstaticcatch (body, (i, ids), handler) ->
let st_exn = Static_exception.create () in
let env = Env.add_static_exception env i st_exn in
let vars = List.map (Variable.create_with_same_name_as_ident) ids in
Static_catch (st_exn, vars, close t env body,
close t (Env.add_vars env ids vars) handler)
| Ltrywith (body, id, handler) ->
let var = Variable.create_with_same_name_as_ident id in
Try_with (close t env body, var, close t (Env.add_var env id var) handler)
| Lifthenelse (cond, ifso, ifnot) ->
let cond = close t env cond in
let cond_var = Variable.create "cond" in
Flambda.create_let cond_var (Expr cond)
(If_then_else (cond_var, close t env ifso, close t env ifnot))
| Lsequence (lam1, lam2) ->
let var = Variable.create "sequence" in
let lam1 = Flambda.Expr (close t env lam1) in
let lam2 = close t env lam2 in
Flambda.create_let var lam1 lam2
| Lwhile (cond, body) -> While (close t env cond, close t env body)
| Lfor (id, lo, hi, direction, body) ->
let bound_var = Variable.create_with_same_name_as_ident id in
let from_value = Variable.create "for_from" in
let to_value = Variable.create "for_to" in
let body = close t (Env.add_var env id bound_var) body in
Flambda.create_let from_value (Expr (close t env lo))
(Flambda.create_let to_value (Expr (close t env hi))
(For { bound_var; from_value; to_value; direction; body; }))
| Lassign (id, new_value) ->
let being_assigned =
match Env.find_mutable_var_exn env id with
| being_assigned -> being_assigned
| exception Not_found ->
Misc.fatal_errorf "Closure_conversion.close: unbound mutable \
variable %s in assignment"
(Ident.unique_name id)
in
let new_value_var = Variable.create "new_value" in
Flambda.create_let new_value_var (Expr (close t env new_value))
(Assign { being_assigned; new_value = new_value_var; })
| Levent (lam, ev) -> add_debug_info ev (close t env lam)
| Lifused _ ->
(* [Lifused] is used to mark that this expression should be alive only if
an identifier is. Every use should have been removed by
[Simplif.simplify_lets], either by replacing by the inner expression,
or by completely removing it (replacing by unit). *)
Misc.fatal_error "[Lifused] should have been removed by \
[Simplif.simplify_lets]"
(** Perform closure conversion on a set of function declarations, returning a
set of closures. (The set will often only contain a single function;
the only case where it cannot is for "let rec".) *)
and close_functions t external_env function_declarations : Flambda.named =
let closure_env_without_parameters =
Function_decls.closure_env_without_parameters
external_env function_declarations
in
let all_free_idents = Function_decls.all_free_idents function_declarations in
let close_one_function map decl =
let body = Function_decl.body decl in
let dbg =
(* Move any debugging event that may exist at the start of the function
body onto the function declaration itself. *)
match body with
| Levent (_, ({ lev_kind = Lev_function } as ev)) ->
Debuginfo.from_call ev
| _ -> Debuginfo.none
in
let params = Function_decl.params decl in
(* Create fresh variables for the elements of the closure (cf.
the comment on [Function_decl.closure_env_without_parameters], above).
This induces a renaming on [Function_decl.free_idents]; the results of
that renaming are stored in [free_variables]. *)
let closure_env =
List.fold_right (fun id env ->
Env.add_var env id (Variable.create_with_same_name_as_ident id))
params closure_env_without_parameters
in
(* If the function is the wrapper for a function with an optional
argument with a default value, make sure it always gets inlined.
CR-someday pchambart: eta-expansion wrapper for a primitive are
not marked as stub but certainly should *)
let stub, body =
match Function_decl.primitive_wrapper decl with
| None -> false, body
| Some wrapper_body -> true, wrapper_body
in
let params = List.map (Env.find_var closure_env) params in
let closure_bound_var = Function_decl.closure_bound_var decl in
let body = close t closure_env body in
let fun_decl =
Flambda.create_function_declaration ~params ~body ~stub ~dbg
~inline:(Function_decl.inline decl)
~is_a_functor:(Function_decl.is_a_functor decl)
in
match Function_decl.kind decl with
| Curried -> Variable.Map.add closure_bound_var fun_decl map
| Tupled ->
let unboxed_version = Variable.rename closure_bound_var in
let generic_function_stub =
tupled_function_call_stub params unboxed_version
in
Variable.Map.add unboxed_version fun_decl
(Variable.Map.add closure_bound_var generic_function_stub map)
in
let function_decls =
Flambda.create_function_declarations
~set_of_closures_id:
(Set_of_closures_id.create (Compilation_unit.get_current_exn ()))
~funs:
(List.fold_left close_one_function Variable.Map.empty
(Function_decls.to_list function_declarations))
in
(* The closed representation of a set of functions is a "set of closures".
(For avoidance of doubt, the runtime representation of the *whole set* is
a single block with tag [Closure_tag].) *)
let set_of_closures =
let free_vars =
IdentSet.fold (fun var map ->
let internal_var =
Env.find_var closure_env_without_parameters var
in
let external_var = Env.find_var external_env var in
Variable.Map.add internal_var external_var map)
all_free_idents Variable.Map.empty
in
Flambda.create_set_of_closures ~function_decls ~free_vars
~specialised_args:Variable.Map.empty
in
Set_of_closures set_of_closures
and close_list t sb l = List.map (close t sb) l
and close_let_bound_expression t ?let_rec_ident let_bound_var env
(lam : Lambda.lambda) : Flambda.named =
match lam with
| Lfunction { kind; params; body; attr; } ->
(* Ensure that [let] and [let rec]-bound functions have appropriate
names. *)
let closure_bound_var = Variable.rename let_bound_var in
let decl =
Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~params
~body ~inline:attr.inline ~is_a_functor:attr.is_a_functor
in
let set_of_closures_var =
Variable.rename let_bound_var ~append:"_set_of_closures"
in
let set_of_closures =
close_functions t env (Function_decls.create [decl])
in
let project_closure : Flambda.project_closure =
{ set_of_closures = set_of_closures_var;
closure_id = Closure_id.wrap closure_bound_var;
}
in
Expr (Flambda.create_let set_of_closures_var set_of_closures
(name_expr (Project_closure (project_closure))
~name:(Variable.unique_name let_bound_var)))
| lam -> Expr (close t env lam)
let lambda_to_flambda ~backend ~module_ident ~size lam : Flambda.program =
let module Backend = (val backend : Backend_intf.S) in
let compilation_unit = Compilation_unit.get_current_exn () in
let t =
{ current_unit_id =
Compilation_unit.get_persistent_ident compilation_unit;
symbol_for_global' = Backend.symbol_for_global';
imported_symbols = Symbol.Set.empty;
}
in
let module_symbol = Backend.symbol_for_global' module_ident in
let block_symbol =
let linkage_name = Linkage_name.create "module_as_block" in
Symbol.create compilation_unit linkage_name
in
(* The global module block is built by accessing the fields of all the
introduced symbols. *)
(* CR-soon mshinwell for mshinwell: Add a comment describing how modules are
compiled. *)
let fields =
Array.init size (fun pos ->
let pos_str = string_of_int pos in
let sym_v = Variable.create ("block_symbol_" ^ pos_str) in
let result_v = Variable.create ("block_symbol_get_" ^ pos_str) in
let value_v = Variable.create ("block_symbol_get_field_" ^ pos_str) in
Flambda.create_let
sym_v (Symbol block_symbol)
(Flambda.create_let result_v
(Prim (Pfield 0, [sym_v], Debuginfo.none))
(Flambda.create_let value_v
(Prim (Pfield pos, [result_v], Debuginfo.none))
(Var value_v))))
in
let module_initializer : Flambda.program_body =
Initialize_symbol (
block_symbol,
Tag.create_exn 0,
[close t Env.empty lam],
Initialize_symbol (
module_symbol,
Tag.create_exn 0,
Array.to_list fields,
End module_symbol))
in
{ imported_symbols = t.imported_symbols;
program_body = module_initializer;
}

50
middle_end/closure_conversion.mli Normal file
View File

@ -0,0 +1,50 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Generation of [Flambda] intermediate language code from [Lambda] code
by performing a form of closure conversion.
Function declarations (which may bind one or more variables identifying
functions, possibly with mutual recursion) are transformed to
[Set_of_closures] expressions. [Project_closure] expressions are then
used to select a closure for a particular function from a [Set_of_closures]
expression. The [Set_of_closures] expressions say nothing about the
actual runtime layout of the closures; this is handled when [Flambda] code
is translated to [Clambda] code.
The following transformations are also performed during closure
conversion:
- Constant blocks (by which is meant things wrapped in [Lambda.Const_block])
are converted to applications of the [Pmakeblock] primitive.
- [Levent] debugging event nodes are removed and the information within
them attached to function, method and [raise] calls.
- Tuplified functions are converted to curried functions and a stub
function emitted to call the curried version. For example:
let rec f (x, y) = f (x + 1, y + 1)
is transformed to:
let rec internal_f x y = f (x + 1,y + 1)
and f (x, y) = internal_f x y (* [f] is marked as a stub function *)
- The [Pdirapply] and [Prevapply] application primitives are removed and
converted to normal [Flambda] application nodes.
The [lambda_to_flambda] function is not re-entrant.
*)
val lambda_to_flambda
: backend:(module Backend_intf.S)
-> module_ident:Ident.t
-> size:int
-> Lambda.lambda
-> Flambda.program

184
middle_end/closure_conversion_aux.ml Normal file
View File

@ -0,0 +1,184 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
module IdentSet = Lambda.IdentSet
module Env = struct
type t = {
variables : Variable.t Ident.tbl;
mutable_variables : Mutable_variable.t Ident.tbl;
static_exceptions : Static_exception.t Numbers.Int.Map.t;
globals : Symbol.t Numbers.Int.Map.t;
at_toplevel : bool;
}
let empty = {
variables = Ident.empty;
mutable_variables = Ident.empty;
static_exceptions = Numbers.Int.Map.empty;
globals = Numbers.Int.Map.empty;
at_toplevel = true;
}
let clear_local_bindings env =
{ empty with globals = env.globals }
let add_var t id var = { t with variables = Ident.add id var t.variables }
let add_vars t ids vars = List.fold_left2 add_var t ids vars
let find_var t id =
try Ident.find_same id t.variables
with Not_found ->
Misc.fatal_errorf "Closure_conversion.Env.find_var: %s@ %s"
(Ident.unique_name id)
(Printexc.raw_backtrace_to_string (Printexc.get_callstack 42))
let find_var_exn t id =
Ident.find_same id t.variables
let add_mutable_var t id mutable_var =
{ t with mutable_variables = Ident.add id mutable_var t.mutable_variables }
let find_mutable_var_exn t id =
Ident.find_same id t.mutable_variables
let add_static_exception t st_exn fresh_st_exn =
{ t with
static_exceptions =
Numbers.Int.Map.add st_exn fresh_st_exn t.static_exceptions }
let find_static_exception t st_exn =
try Numbers.Int.Map.find st_exn t.static_exceptions
with Not_found ->
Misc.fatal_error ("Closure_conversion.Env.find_static_exception: exn "
^ string_of_int st_exn)
let add_global t pos symbol =
{ t with globals = Numbers.Int.Map.add pos symbol t.globals }
let find_global t pos =
try Numbers.Int.Map.find pos t.globals
with Not_found ->
Misc.fatal_error ("Closure_conversion.Env.find_global: global "
^ string_of_int pos)
let at_toplevel t = t.at_toplevel
let not_at_toplevel t = { t with at_toplevel = false; }
end
module Function_decls = struct
module Function_decl = struct
type t = {
let_rec_ident : Ident.t;
closure_bound_var : Variable.t;
kind : Lambda.function_kind;
params : Ident.t list;
body : Lambda.lambda;
free_idents_of_body : IdentSet.t;
inline : Lambda.inline_attribute;
is_a_functor : bool;
}
let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body ~inline
~is_a_functor =
let let_rec_ident =
match let_rec_ident with
| None -> Ident.create "unnamed_function"
| Some let_rec_ident -> let_rec_ident
in
{ let_rec_ident;
closure_bound_var;
kind;
params;
body;
free_idents_of_body = Lambda.free_variables body;
inline;
is_a_functor;
}
let let_rec_ident t = t.let_rec_ident
let closure_bound_var t = t.closure_bound_var
let kind t = t.kind
let params t = t.params
let body t = t.body
let free_idents t = t.free_idents_of_body
let inline t = t.inline
let is_a_functor t = t.is_a_functor
(* CR-someday mshinwell: eliminate "*stub*" *)
let primitive_wrapper t =
match t.body with
| Lprim (Pccall { Primitive.prim_name = "*stub*" }, [body]) -> Some body
| _ -> None
end
type t = {
function_decls : Function_decl.t list;
all_free_idents : IdentSet.t;
}
(* All identifiers free in the bodies of the given function declarations,
indexed by the identifiers corresponding to the functions themselves. *)
let free_idents_by_function function_decls =
List.fold_right (fun decl map ->
Variable.Map.add (Function_decl.closure_bound_var decl)
(Function_decl.free_idents decl) map)
function_decls Variable.Map.empty
let all_free_idents function_decls =
Variable.Map.fold (fun _ -> IdentSet.union)
(free_idents_by_function function_decls) IdentSet.empty
(* All identifiers of simultaneously-defined functions in [ts]. *)
let let_rec_idents function_decls =
List.map Function_decl.let_rec_ident function_decls
(* All parameters of functions in [ts]. *)
let all_params function_decls =
List.concat (List.map Function_decl.params function_decls)
let set_diff (from : IdentSet.t) (idents : Ident.t list) =
List.fold_right IdentSet.remove idents from
(* CR lwhite: use a different name from above or explain the difference *)
let all_free_idents function_decls =
set_diff (set_diff (all_free_idents function_decls)
(all_params function_decls))
(let_rec_idents function_decls)
let create function_decls =
{ function_decls;
all_free_idents = all_free_idents function_decls;
}
let to_list t = t.function_decls
let all_free_idents t = t.all_free_idents
let closure_env_without_parameters external_env t =
let closure_env =
(* For "let rec"-bound functions. *)
List.fold_right (fun function_decl env ->
Env.add_var env (Function_decl.let_rec_ident function_decl)
(Function_decl.closure_bound_var function_decl))
t.function_decls (Env.clear_local_bindings external_env)
in
(* For free variables. *)
IdentSet.fold (fun id env ->
Env.add_var env id (Variable.create (Ident.name id)))
t.all_free_idents closure_env
end

94
middle_end/closure_conversion_aux.mli Normal file
View File

@ -0,0 +1,94 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Environments and auxiliary structures used during closure conversion. *)
(** Used to remember which [Variable.t] values correspond to which
[Ident.t] values during closure conversion, and similarly for
static exception identifiers. *)
module Env : sig
type t
val empty : t
val add_var : t -> Ident.t -> Variable.t -> t
val add_vars : t -> Ident.t list -> Variable.t list -> t
val find_var : t -> Ident.t -> Variable.t
val find_var_exn : t -> Ident.t -> Variable.t
val add_mutable_var : t -> Ident.t -> Mutable_variable.t -> t
val find_mutable_var_exn : t -> Ident.t -> Mutable_variable.t
val add_static_exception : t -> int -> Static_exception.t -> t
val find_static_exception : t -> int -> Static_exception.t
val add_global : t -> int -> Symbol.t -> t
val find_global : t -> int -> Symbol.t
val at_toplevel : t -> bool
val not_at_toplevel : t -> t
end
(** Used to represent information about a set of function declarations
during closure conversion. (The only case in which such a set may
contain more than one declaration is when processing "let rec".) *)
module Function_decls : sig
module Function_decl : sig
type t
val create
: let_rec_ident:Ident.t option
-> closure_bound_var:Variable.t
-> kind:Lambda.function_kind
-> params:Ident.t list
-> body:Lambda.lambda
-> inline:Lambda.inline_attribute
-> is_a_functor:bool
-> t
val let_rec_ident : t -> Ident.t
val closure_bound_var : t -> Variable.t
val kind : t -> Lambda.function_kind
val params : t -> Ident.t list
val body : t -> Lambda.lambda
val inline : t -> Lambda.inline_attribute
val is_a_functor : t -> bool
(* [primitive_wrapper t] is [None] iff [t] is not a wrapper for a function
with default optionnal arguments. Otherwise it is [Some body], where
[body] is the body of the wrapper. *)
val primitive_wrapper : t -> Lambda.lambda option
(* Like [all_free_idents], but for just one function. *)
val free_idents : t -> Lambda.IdentSet.t
end
type t
val create : Function_decl.t list -> t
val to_list : t -> Function_decl.t list
(* All identifiers free in the given function declarations after the binding
of parameters and function identifiers has been performed. *)
val all_free_idents : t -> Lambda.IdentSet.t
(* A map from identifiers to their corresponding [Variable.t]s whose domain
is the set of all identifiers free in the bodies of the declarations that
are not bound as parameters.
It also contains the globals bindings of the provided environment. *)
val closure_env_without_parameters : Env.t -> t -> Env.t
end

55
middle_end/effect_analysis.ml Normal file
View File

@ -0,0 +1,55 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 no_effects_prim (prim : Lambda.primitive) =
match Semantics_of_primitives.for_primitive prim with
| (No_effects | Only_generative_effects), (No_coeffects | Has_coeffects) ->
true
| _ -> false
let rec no_effects (flam : Flambda.t) =
match flam with
| Var _ -> true
| Let { defining_expr; body; _ } ->
no_effects_named defining_expr && no_effects body
| Let_mutable (_, _, body) -> no_effects body
| Let_rec (defs, body) ->
no_effects body
&& List.for_all (fun (_, def) -> no_effects_named def) defs
| If_then_else (_, ifso, ifnot) -> no_effects ifso && no_effects ifnot
| Switch (_, sw) ->
let aux (_, flam) = no_effects flam in
List.for_all aux sw.blocks
&& List.for_all aux sw.consts
&& Misc.may_default no_effects sw.failaction true
| String_switch (_, sw, def) ->
List.for_all (fun (_, lam) -> no_effects lam) sw
&& Misc.may_default no_effects def true
| Static_catch (_, _, body, _) | Try_with (body, _, _) ->
(* If there is a [raise] in [body], the whole [Try_with] may have an
effect, so there is no need to test the handler. *)
no_effects body
| While _ | For _ | Apply _ | Send _ | Assign _ | Static_raise _ -> false
| Proved_unreachable -> true
and no_effects_named (named : Flambda.named) =
match named with
| Symbol _ | Const _ | Allocated_const _ | Read_mutable _
| Read_symbol_field _
| Set_of_closures _ | Project_closure _ | Project_var _
| Move_within_set_of_closures _ -> true
| Prim (prim, _, _) -> no_effects_prim prim
| Expr flam -> no_effects flam

25
middle_end/effect_analysis.mli Normal file
View File

@ -0,0 +1,25 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Simple side effect analysis. *)
(* CR-someday pchambart: Replace by call to [Purity] module.
mshinwell: Where is the [Purity] module? *)
(** Conservative approximation as to whether a given Flambda expression may
have any side effects. *)
val no_effects : Flambda.t -> bool
val no_effects_named : Flambda.named -> bool

29
middle_end/find_recursive_functions.ml Normal file
View File

@ -0,0 +1,29 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
let in_function_declarations (function_decls : Flambda.function_declarations)
~backend =
let module VCC = Sort_connected_components.Make (Variable) in
let directed_graph =
Flambda_utils.fun_vars_referenced_in_decls function_decls ~backend
in
let connected_components =
VCC.connected_components_sorted_from_roots_to_leaf directed_graph
in
Array.fold_left (fun rec_fun -> function
| VCC.No_loop _ -> rec_fun
| VCC.Has_loop elts -> List.fold_right Variable.Set.add elts rec_fun)
Variable.Set.empty connected_components

35
middle_end/find_recursive_functions.mli Normal file
View File

@ -0,0 +1,35 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** "Recursive functions" are those functions [f] that might call either:
- themselves, or
- another function that in turn might call [f].
For example in the following simultaneous definition of [f] [g] and [h],
[f] and [g] are recursive functions, but not [h]:
[let rec f x = g x
and g x = f x
and h x = g x]
*)
(** Determine the recursive functions, if any, bound by the given set of
function declarations.
This is only intended to be used by [Flambda.create_function_declarations].
*)
val in_function_declarations
: Flambda.function_declarations
-> backend:(module Backend_intf.S)
-> Variable.Set.t

1117
middle_end/flambda.ml Normal file
View File

File diff suppressed because it is too large Load Diff

601
middle_end/flambda.mli Normal file
View File

@ -0,0 +1,601 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(** Intermediate language used for tree-based analysis and optimization. *)
(** Whether the callee in a function application is known at compile time. *)
type call_kind =
| Indirect
| Direct of Closure_id.t
(** Simple constants. ("Structured constants" are rewritten to invocations
of [Pmakeblock] so that they easily take part in optimizations.) *)
type const =
| Int of int
| Char of char
(** [Char] is kept separate from [Int] to improve printing *)
| Const_pointer of int
(** [Const_pointer] is an immediate value of a type whose values may be
boxed (typically a variant type with both constant and non-constant
constructors). *)
(** The application of a function to a list of arguments. *)
type apply = {
(* CR-soon mshinwell: rename func -> callee, and
lhs_of_application -> callee *)
func : Variable.t;
args : Variable.t list;
kind : call_kind;
dbg : Debuginfo.t;
inline : Lambda.inline_attribute;
(** Instructions from the source code as to whether the callee should
be inlined. *)
}
(** The update of a mutable variable. Mutable variables are distinct from
immutable variables in Flambda. *)
type assign = {
being_assigned : Mutable_variable.t;
new_value : Variable.t;
}
(** The invocation of a method. *)
type send = {
kind : Lambda.meth_kind;
meth : Variable.t;
obj : Variable.t;
args : Variable.t list;
dbg : Debuginfo.t;
}
(** The selection of one closure given a set of closures, required before
a function defined by said set of closures can be applied. See more
detailed documentation below on [set_of_closures]. *)
type project_closure = {
set_of_closures : Variable.t; (** must yield a set of closures *)
closure_id : Closure_id.t;
}
(** The selection of one closure given another closure in the same set of
closures. See more detailed documentation below on [set_of_closures]. *)
type move_within_set_of_closures = {
closure : Variable.t; (** must yield a closure *)
start_from : Closure_id.t;
move_to : Closure_id.t;
}
(** The selection from a closure of a variable bound by said closure.
In other words, access to a function's environment. Also see more
detailed documentation below on [set_of_closures]. *)
type project_var = {
closure : Variable.t; (** must yield a closure *)
closure_id : Closure_id.t;
var : Var_within_closure.t;
}
(** Flambda terms are partitioned in a pseudo-ANF manner; many terms are
required to be [let]-bound. This in particular ensures there is always
a variable name for an expression that may be lifted out (for example
if it is found to be constant).
Note: All bound variables in Flambda terms must be distinct.
[Flambda_invariants] verifies this. *)
type t =
| Var of Variable.t
| Let of let_expr
| Let_mutable of Mutable_variable.t * Variable.t * t
| Let_rec of (Variable.t * named) list * t
(** CR-someday lwhite: give Let_rec the same fields as Let. *)
| Apply of apply
| Send of send
| Assign of assign
| If_then_else of Variable.t * t * t
| Switch of Variable.t * switch
| String_switch of Variable.t * (string * t) list * t option
(** Restrictions on [Lambda.Lstringswitch] also apply to [String_switch]. *)
| Static_raise of Static_exception.t * Variable.t list
| Static_catch of Static_exception.t * Variable.t list * t * t
| Try_with of t * Variable.t * t
| While of t * t
| For of for_loop
| Proved_unreachable
(** Values of type [named] will always be [let]-bound to a [Variable.t]. *)
and named =
| Symbol of Symbol.t
| Const of const
| Allocated_const of Allocated_const.t
| Read_mutable of Mutable_variable.t
| Read_symbol_field of Symbol.t * int
(** During the lifting of [let] bindings to [program] constructions after
closure conversion, we generate symbols and their corresponding
definitions (which may or may not be constant), together with field
accesses to such symbols. We would like it to be the case that such
field accesses are simplified to the relevant component of the
symbol concerned. (The rationale is to generate efficient code and
share constants as expected: see e.g. tests/asmcomp/staticalloc.ml.)
The components of the symbol would be identified by other symbols.
This sort of access pattern is feasible because the top-level structure
of symbols is statically allocated and fixed at compile time.
It may seem that [Prim (Pfield, ...)] expressions could be used to
perform the field accesses. However for simplicity, to avoid having to
keep track of properties of individual fields of blocks,
[Inconstant_idents] never deems a [Prim (Pfield, ...)] expression to be
constant. This would in general prevent field accesses to symbols from
being simplified in the way we would like, since [Lift_constants] would
not assign new symbols (i.e. the things we would like to simplify to)
to the various projections from the symbols in question.
To circumvent this problem we use [Read_symbol_field] when generating
projections from the top level of symbols. Owing to the properties of
symbols described above, such expressions may be eligible for declaration
as constant by [Inconstant_idents] (and thus themselves lifted to another
symbol), without any further complication.
[Read_symbol_field] may only be used when the definition of the symbol
is in scope in the [program]. For external unresolved symbols, [Pfield]
may still be used; it will be changed to [Read_symbol_field] by
[Inline_and_simplify] when (and if) the symbol is imported. *)
| Set_of_closures of set_of_closures
| Project_closure of project_closure
| Move_within_set_of_closures of move_within_set_of_closures
| Project_var of project_var
| Prim of Lambda.primitive * Variable.t list * Debuginfo.t
| Expr of t (** ANF escape hatch. *)
(* CR-someday mshinwell: use [letcont]-style construct to remove e.g.
[While] and [For]. *)
(* CR-someday mshinwell: try to produce a tighter definition of a "switch"
(and translate to that earlier) so that middle- and back-end code for
these can be reduced. *)
(* CR-someday mshinwell: remove [Expr], but to do this easily would probably
require a continuation-binding construct. *)
(* CR-someday mshinwell: Since we lack expression identifiers on every term,
we should probably introduce [Mutable_var] into [named] if we introduce
more complicated analyses on these in the future. Alternatively, maybe
consider removing mutable variables altogether. *)
and let_expr = private {
var : Variable.t;
defining_expr : named;
body : t;
(* CR-someday mshinwell: we could consider having these be keys into some
kind of global cache, to reduce memory usage. *)
free_vars_of_defining_expr : Variable.Set.t;
(** A cache of the free variables in the defining expression of the [let]. *)
free_vars_of_body : Variable.Set.t;
(** A cache of the free variables of the body of the [let]. This is an
important optimization. *)
}
(** The representation of a set of function declarations (possibly mutually
recursive). Such a set encapsulates the declarations themselves,
information about their defining environment, and information used
specifically for optimization.
Before a function can be applied it must be "projected" from a set of
closures to yield a "closure". This is done using [Project_closure]
(see above). Given a closure, not only can it be applied, but information
about its defining environment can be retrieved (using [Project_var],
see above).
At runtime, a [set_of_closures] corresponds to an OCaml value with tag
[Closure_tag] (possibly with inline [Infix_tag](s)). As an optimization,
an operation ([Move_within_set_of_closures]) is provided (see above)
which enables one closure within a set to be located given another
closure in the same set. This avoids keeping a pointer to the whole set
of closures alive when compiling, for example, mutually-recursive
functions.
*)
and set_of_closures = private {
function_decls : function_declarations;
(* CR-soon mshinwell: consider renaming [free_vars]. Also, it's still really
confusing which side of this map to use when. "Vars bound by the
closure" is the domain.
Another example of when this is confusing:
let bound_vars_approx =
Variable.Map.map (Env.find_approx env) set.free_vars
in
in [Build_export_info]. *)
free_vars : Variable.t Variable.Map.t;
(** Mapping from all variables free in the body of the [function_decls] to
variables in scope at the definition point of the [set_of_closures].
The domain of this map is sometimes known as the "variables bound by
the closure". *)
specialised_args : Variable.t Variable.Map.t;
(** Parameters known to always alias some variable in the scope of the set
of closures declaration. These are the only parameters that may,
during [Inline_and_simplify], have non-unknown approximations.
For instance, supposing all call sites of f are represented in this
example,
[let x = ... in
let f a b c = ... in
let y = ... in
f x y 1;
f x y 1]
the specialised arguments of f can (but does not necessarily) contain
the association [a] -> [x], but cannot contain [b] -> [y] because [f]
is not in the scope of [y]. If f were the recursive function
[let rec f a b c = f a 1 2 in], [a] -> [x] would still be a valid
specialised argument because all recursive calls maintain the invariant.
This information is used for optimisation purposes, if such a binding is
known, it is possible to specialise the body of the function according
to its parameter. This is usually introduced when specialising a
recursive function, for instance.
[let rec map f = function
| [] -> []
| h :: t -> f h :: map f t
let map_succ l =
let succ x = x + 1 in
map succ l]
[map] can be duplicated in [map_succ] to be specialised for the argument
[f]. This will result in
[let map_succ l =
let succ x = x + 1 in
let rec map f = function
| [] -> []
| h :: t -> f h :: map f t in
map succ l]
with map having [f] -> [succ] in its [specialised_args] field.
Note that it is usually not correct to erase this information if the
argument is used.
*)
(* CR mshinwell for pchambart: expand upon the last sentence of the previous
comment *)
}
and function_declarations = private {
set_of_closures_id : Set_of_closures_id.t;
(** An identifier (unique across all Flambda trees currently in memory)
of the set of closures associated with this set of function
declarations. *)
funs : function_declaration Variable.Map.t;
(** The function(s) defined by the set of function declarations. The
keys of this map are often referred to in the code as "fun_var"s. *)
}
and function_declaration = private {
params : Variable.t list;
body : t;
(* CR-soon mshinwell: inconsistent naming free_variables/free_vars here and
above *)
free_variables : Variable.Set.t;
(** All variables free in the *body* of the function. For example, a
variable that is bound as one of the function's parameters will still
be included in this set. This field is present as an optimization. *)
free_symbols : Symbol.Set.t;
(** All symbols that occur in the function's body. (Symbols can never be
bound in a function's body; the only thing that binds symbols is the
[program] constructions below.) *)
stub : bool;
(** A stub function is a generated function used to prepare arguments or
return values to allow indirect calls to functions with a special calling
convention. For instance indirect calls to tuplified functions must go
through a stub. Stubs will be unconditionally inlined. *)
dbg : Debuginfo.t;
(** Debug info for the function declaration. *)
inline : Lambda.inline_attribute;
(** Inlining requirements from the source code. *)
is_a_functor : bool;
(** Whether the function is known definitively to be a functor. *)
}
(** Equivalent to the similar type in [Lambda]. *)
and switch = {
numconsts : Numbers.Int.Set.t; (** Integer cases *)
consts : (int * t) list; (** Integer cases *)
numblocks : Numbers.Int.Set.t; (** Number of tag block cases *)
blocks : (int * t) list; (** Tag block cases *)
failaction : t option; (** Action to take if none matched *)
}
(** Equivalent to the similar type in [Lambda]. *)
and for_loop = {
bound_var : Variable.t;
from_value : Variable.t;
to_value : Variable.t;
direction : Asttypes.direction_flag;
body : t
}
(** Like a subset of [Flambda.named], except that instead of [Variable.t]s we
have [Symbol.t]s, and everything is a constant (i.e. with a fixed value
known at compile time). Values of this type describe constants that will
be directly assigned to symbols in the object file (see below). *)
and constant_defining_value =
| Allocated_const of Allocated_const.t
(** A single constant. These are never "simple constants" (type [const])
but instead more complicated constructions. *)
| Block of Tag.t * constant_defining_value_block_field list
(** A pre-allocated block full of constants (either simple constants
or references to other constants, see below). *)
| Set_of_closures of set_of_closures
(** A closed (and thus constant) set of closures. (That is to say,
[free_vars] must be empty.) *)
| Project_closure of Symbol.t * Closure_id.t
(** Selection of one closure from a constant set of closures.
Analogous to the equivalent operation on expressions. *)
and constant_defining_value_block_field =
| Symbol of Symbol.t
| Const of const
module Constant_defining_value :
Identifiable.S with type t = constant_defining_value
type expr = t
(** A "program" is the contents of one compilation unit. It describes the
various values that are assigned to symbols (and in some cases fields of
such symbols) in the object file. As such, it is closely related to
the compilation of toplevel modules. *)
type program_body =
| Let_symbol of Symbol.t * constant_defining_value * program_body
(** Define the given symbol to have the given constant value. *)
| Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body
(** As for [Let_symbol], but recursive. This is needed to treat examples
like this, where a constant set of closures is lifted to toplevel:
let rec f x = f x
After lifting this produces (in pseudo-Flambda):
Let_rec_symbol set_of_closures_symbol =
(Set_of_closures { f x ->
let applied_function = Symbol f_closure in
Apply (applied_function, x) })
and f_closure = Project_closure (set_of_closures_symbol, f)
Use of [Let_rec_symbol], by virtue of the special handling in
[Inline_and_simplify.define_let_rec_symbol_approx], enables the
approximation of the set of closures to be present in order to
correctly simplify the [Project_closure] construction. (See
[Inline_and_simplify.simplify_project_closure] for that part.) *)
| Initialize_symbol of Symbol.t * Tag.t * t list * program_body
(** Define the given symbol as a constant block of the given size and
tag; but with a possibly non-constant initializer. The initializer
will be executed at most once (from the entry point of the compilation
unit). *)
| Effect of t * program_body
(** Cause the given expression, which may have a side effect, to be
executed. The resulting value is discarded. [Effect] constructions
are never re-ordered. *)
| End of Symbol.t
(** [End] accepts the root symbol: the only symbol that can never be
eliminated. *)
type program = {
imported_symbols : Symbol.Set.t;
program_body : program_body;
}
(** Compute the free variables of a term. (This is O(1) for [Let]s).
If [ignore_uses_as_callee], all free variables inside [Apply] expressions
are ignored. Likewise [ignore_uses_in_project_var] for [Project_var]
expressions.
*)
val free_variables
: ?ignore_uses_as_callee:unit
-> ?ignore_uses_as_argument:unit
-> ?ignore_uses_in_project_var:unit
-> t
-> Variable.Set.t
(** Compute the free variables of a named expression. *)
val free_variables_named
: ?ignore_uses_in_project_var:unit
-> named
-> Variable.Set.t
(** Compute _all_ variables occuring inside an expression. (This is O(1)
for [Let]s). *)
val used_variables
: ?ignore_uses_as_callee:unit
-> ?ignore_uses_as_argument:unit
-> ?ignore_uses_in_project_var:unit
-> t
-> Variable.Set.t
(** Compute _all_ variables occurring inside a named expression. *)
val used_variables_named
: ?ignore_uses_in_project_var:unit
-> named
-> Variable.Set.t
val free_symbols : expr -> Symbol.Set.t
val free_symbols_named : named -> Symbol.Set.t
val free_symbols_program : program -> Symbol.Set.t
(** Used to avoid exceeding the stack limit when handling expressions with
multiple consecutive nested [Let]-expressions. This saves rewriting large
simplification functions in CPS. This function provides for the
rewriting or elimination of expressions during the fold. *)
val fold_lets_option
: t
-> init:'a
-> for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named)
-> for_last_body:('a -> t -> t * 'b)
(* CR-someday mshinwell: consider making [filter_defining_expr]
optional *)
-> filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t ->
'b * Variable.t * named option)
-> t * 'b
(** Like [fold_lets_option], but just a map. *)
val map_lets
: t
-> for_defining_expr:(Variable.t -> named -> named)
-> for_last_body:(t -> t)
-> after_rebuild:(t -> t)
-> t
(** Like [map_lets], but just an iterator. *)
val iter_lets
: t
-> for_defining_expr:(Variable.t -> named -> unit)
-> for_last_body:(t -> unit)
-> for_each_let:(t -> unit)
-> unit
(** Creates a [Let] expression. (This computes the free variables of the
defining expression and the body.) *)
val create_let : Variable.t -> named -> t -> t
(** Apply the specified function [f] to the defining expression of the given
[Let]-expression, returning a new [Let]. *)
val map_defining_expr_of_let : let_expr -> f:(named -> named) -> t
(** A module for the manipulation of terms where the recomputation of free
variable sets is to be kept to a minimum. *)
module With_free_variables : sig
type 'a t
(** O(1) time. *)
val of_defining_expr_of_let : let_expr -> named t
(** O(1) time. *)
val of_body_of_let : let_expr -> expr t
(** Takes the time required to calculate the free variables of the given
term (proportional to the size of the term, except that the calculation
for [Let] is O(1)). *)
val of_expr : expr -> expr t
val of_named : named -> named t
(** Takes the time required to calculate the free variables of the given
[expr]. *)
val create_let_reusing_defining_expr
: Variable.t
-> named t
-> expr
-> expr
(** Takes the time required to calculate the free variables of the given
[named]. *)
val create_let_reusing_body
: Variable.t
-> named
-> expr t
-> expr
(** O(1) time. *)
val create_let_reusing_both
: Variable.t
-> named t
-> expr t
-> expr
(** The equivalent of the [Expr] constructor. *)
val expr : expr t -> named t
val contents : 'a t -> 'a
(** O(1) time. *)
val free_variables : _ t -> Variable.Set.t
end
(** Create a function declaration. This calculates the free variables and
symbols occurring in the specified [body]. *)
val create_function_declaration
: params:Variable.t list
-> body:t
-> stub:bool
-> dbg:Debuginfo.t
-> inline:Lambda.inline_attribute
-> is_a_functor:bool
-> function_declaration
(** Create a set of function declarations given the individual declarations. *)
val create_function_declarations
: set_of_closures_id:Set_of_closures_id.t
-> funs:function_declaration Variable.Map.t
-> function_declarations
(** Convenience function to replace the [funs] member of a set of
function declarations. *)
val update_function_declarations
: function_declarations
-> funs:function_declaration Variable.Map.t
-> function_declarations
(** Create a set of closures. Checks are made to ensure that [free_vars]
and [specialised_args] are reasonable. *)
val create_set_of_closures
: function_decls:function_declarations
-> free_vars:Variable.t Variable.Map.t
-> specialised_args:Variable.t Variable.Map.t
-> set_of_closures
(** Given a function declaration, find which of its parameters (if any)
are used in the body. *)
val used_params : function_declaration -> Variable.Set.t
type maybe_named =
| Is_expr of t
| Is_named of named
(** This function is designed for the internal use of [Flambda_iterators].
See that module for iterators to be used over Flambda terms. *)
val iter_general
: toplevel:bool
-> (t -> unit)
-> (named -> unit)
-> maybe_named
-> unit
val print : Format.formatter -> t -> unit
val print_named : Format.formatter -> named -> unit
val print_program : Format.formatter -> program -> unit
val print_const : Format.formatter -> const -> unit
val print_constant_defining_value
: Format.formatter
-> constant_defining_value
-> unit
val print_function_declaration
: Format.formatter
-> Variable.t * function_declaration
-> unit
val print_function_declarations
: Format.formatter
-> function_declarations
-> unit
val print_project_closure
: Format.formatter
-> project_closure
-> unit
val print_move_within_set_of_closures
: Format.formatter
-> move_within_set_of_closures
-> unit
val print_project_var
: Format.formatter
-> project_var
-> unit
val print_set_of_closures
: Format.formatter
-> set_of_closures
-> unit

731
middle_end/flambda_invariants.ml Normal file
View File

@ -0,0 +1,731 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 flambda_kind =
| Normal
| Lifted
(* Explicit "ignore" functions. We name every pattern variable, avoiding
underscores, to try to avoid accidentally failing to handle (for example)
a particular variable.
We also avoid explicit record field access during the checking functions,
preferring instead to use exhaustive record matches.
*)
(* CR-someday pchambart: for sum types, we should probably add an exhaustive
pattern in ignores functions to be reminded if a type change *)
let already_added_bound_variable_to_env (_ : Variable.t) = ()
let will_traverse_named_expression_later (_ : Flambda.named) = ()
let ignore_variable (_ : Variable.t) = ()
let ignore_call_kind (_ : Flambda.call_kind) = ()
let ignore_debuginfo (_ : Debuginfo.t) = ()
let ignore_meth_kind (_ : Lambda.meth_kind) = ()
let ignore_int (_ : int) = ()
let ignore_int_set (_ : Numbers.Int.Set.t) = ()
let ignore_bool (_ : bool) = ()
let ignore_string (_ : string) = ()
let ignore_static_exception (_ : Static_exception.t) = ()
let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
let ignore_primitive ( _ : Lambda.primitive) = ()
let ignore_const (_ : Flambda.const) = ()
let ignore_allocated_const (_ : Allocated_const.t) = ()
let ignore_set_of_closures_id (_ : Set_of_closures_id.t) = ()
let ignore_closure_id (_ : Closure_id.t) = ()
let ignore_var_within_closure (_ : Var_within_closure.t) = ()
let ignore_tag (_ : Tag.t) = ()
let ignore_inline_attribute (_ : Lambda.inline_attribute) = ()
exception Binding_occurrence_not_from_current_compilation_unit of Variable.t
exception Mutable_binding_occurrence_not_from_current_compilation_unit of
Mutable_variable.t
exception Binding_occurrence_of_variable_already_bound of Variable.t
exception Binding_occurrence_of_mutable_variable_already_bound of
Mutable_variable.t
exception Binding_occurrence_of_symbol_already_bound of Symbol.t
exception Unbound_variable of Variable.t
exception Unbound_mutable_variable of Mutable_variable.t
exception Unbound_symbol of Symbol.t
exception Vars_in_function_body_not_bound_by_closure_or_params of
Variable.Set.t * Flambda.set_of_closures * Variable.t
exception Function_decls_have_overlapping_parameters of Variable.Set.t
exception Specialised_arg_that_is_not_a_parameter of Variable.t
exception Free_variables_set_is_lying of
Variable.t * Variable.Set.t * Variable.Set.t * Flambda.function_declaration
exception Set_of_closures_free_vars_map_has_wrong_range of Variable.Set.t
exception Static_exception_not_caught of Static_exception.t
exception Static_exception_caught_in_multiple_places of Static_exception.t
exception Access_to_global_module_identifier of Lambda.primitive
exception Pidentity_should_not_occur
exception Pdirapply_should_be_expanded
exception Prevapply_should_be_expanded
exception Sequential_logical_operator_primitives_must_be_expanded of
Lambda.primitive
exception Var_within_closure_bound_multiple_times of Var_within_closure.t
exception Declared_closure_from_another_unit of Compilation_unit.t
exception Closure_id_is_bound_multiple_times of Closure_id.t
exception Set_of_closures_id_is_bound_multiple_times of Set_of_closures_id.t
exception Unbound_closure_ids of Closure_id.Set.t
exception Unbound_vars_within_closures of Var_within_closure.Set.t
exception Flambda_invariants_failed
(* CR-someday mshinwell: We should make "direct applications should not have
overapplication" be an invariant throughout. At the moment I think this is
only true after [Inline_and_simplify] has split overapplications. *)
(* CR-someday mshinwell: What about checks for shadowed variables and symbols? *)
let variable_and_symbol_invariants (program : Flambda.program) =
let all_declared_variables = ref Variable.Set.empty in
let declare_variable var =
if Variable.Set.mem var !all_declared_variables then
raise (Binding_occurrence_of_variable_already_bound var);
all_declared_variables := Variable.Set.add var !all_declared_variables
in
let declare_variables vars =
Variable.Set.iter declare_variable vars
in
let all_declared_mutable_variables = ref Mutable_variable.Set.empty in
let declare_mutable_variable mut_var =
if Mutable_variable.Set.mem mut_var !all_declared_mutable_variables then
raise (Binding_occurrence_of_mutable_variable_already_bound mut_var);
all_declared_mutable_variables :=
Mutable_variable.Set.add mut_var !all_declared_mutable_variables
in
let add_binding_occurrence (var_env, mut_var_env, sym_env) var =
let compilation_unit = Compilation_unit.get_current_exn () in
if not (Variable.in_compilation_unit var compilation_unit) then
raise (Binding_occurrence_not_from_current_compilation_unit var);
declare_variable var;
Variable.Set.add var var_env, mut_var_env, sym_env
in
let add_mutable_binding_occurrence (var_env, mut_var_env, sym_env) mut_var =
let compilation_unit = Compilation_unit.get_current_exn () in
if not (Mutable_variable.in_compilation_unit mut_var compilation_unit) then
raise (Mutable_binding_occurrence_not_from_current_compilation_unit
mut_var);
declare_mutable_variable mut_var;
var_env, Mutable_variable.Set.add mut_var mut_var_env, sym_env
in
let add_binding_occurrence_of_symbol (var_env, mut_var_env, sym_env) sym =
if Symbol.Set.mem sym sym_env then
raise (Binding_occurrence_of_symbol_already_bound sym)
else
var_env, mut_var_env, Symbol.Set.add sym sym_env
in
let add_binding_occurrences env vars =
List.fold_left (fun env var -> add_binding_occurrence env var) env vars
in
let check_variable_is_bound (var_env, _, _) var =
if not (Variable.Set.mem var var_env) then raise (Unbound_variable var)
in
let check_symbol_is_bound (_, _, sym_env) sym =
if not (Symbol.Set.mem sym sym_env) then raise (Unbound_symbol sym)
in
let check_variables_are_bound env vars =
List.iter (check_variable_is_bound env) vars
in
let check_mutable_variable_is_bound (_, mut_var_env, _) mut_var =
if not (Mutable_variable.Set.mem mut_var mut_var_env) then begin
raise (Unbound_mutable_variable mut_var)
end
in
let rec loop env (flam : Flambda.t) =
match flam with
(* Expressions that can bind [Variable.t]s: *)
| Let { var; defining_expr; body; _ } ->
loop_named env defining_expr;
loop (add_binding_occurrence env var) body
| Let_mutable (mut_var, var, body) ->
check_variable_is_bound env var;
loop (add_mutable_binding_occurrence env mut_var) body
| Let_rec (defs, body) ->
let env =
List.fold_left (fun env (var, def) ->
will_traverse_named_expression_later def;
add_binding_occurrence env var)
env defs
in
List.iter (fun (var, def) ->
already_added_bound_variable_to_env var;
loop_named env def) defs;
loop env body
| For { bound_var; from_value; to_value; direction; body; } ->
ignore_direction_flag direction;
check_variable_is_bound env from_value;
check_variable_is_bound env to_value;
loop (add_binding_occurrence env bound_var) body
| Static_catch (static_exn, vars, body, handler) ->
ignore_static_exception static_exn;
loop env body;
loop (add_binding_occurrences env vars) handler
| Try_with (body, var, handler) ->
loop env body;
loop (add_binding_occurrence env var) handler
(* Everything else: *)
| Var var -> check_variable_is_bound env var
| Apply { func; args; kind; dbg; inline } ->
check_variable_is_bound env func;
check_variables_are_bound env args;
ignore_call_kind kind;
ignore_debuginfo dbg;
ignore_inline_attribute inline
| Assign { being_assigned; new_value; } ->
check_mutable_variable_is_bound env being_assigned;
check_variable_is_bound env new_value
| Send { kind; meth; obj; args; dbg; } ->
ignore_meth_kind kind;
check_variable_is_bound env meth;
check_variable_is_bound env obj;
check_variables_are_bound env args;
ignore_debuginfo dbg
| If_then_else (cond, ifso, ifnot) ->
check_variable_is_bound env cond;
loop env ifso;
loop env ifnot
| Switch (arg, { numconsts; consts; numblocks; blocks; failaction; }) ->
check_variable_is_bound env arg;
ignore_int_set numconsts;
ignore_int_set numblocks;
List.iter (fun (n, e) ->
ignore_int n;
loop env e)
(consts @ blocks);
Misc.may (loop env) failaction
| String_switch (arg, cases, e_opt) ->
check_variable_is_bound env arg;
List.iter (fun (label, case) ->
ignore_string label;
loop env case)
cases;
Misc.may (loop env) e_opt
| Static_raise (static_exn, es) ->
ignore_static_exception static_exn;
List.iter (check_variable_is_bound env) es
| While (e1, e2) ->
loop env e1;
loop env e2
| Proved_unreachable -> ()
and loop_named env (named : Flambda.named) =
match named with
| Symbol symbol -> check_symbol_is_bound env symbol
| Const const -> ignore_const const
| Allocated_const const -> ignore_allocated_const const
| Read_mutable mut_var ->
check_mutable_variable_is_bound env mut_var
| Read_symbol_field (symbol, index) ->
check_symbol_is_bound env symbol;
assert (index >= 0) (* CR-someday mshinwell: add proper error *)
| Set_of_closures set_of_closures ->
loop_set_of_closures env set_of_closures
| Project_closure { set_of_closures; closure_id; } ->
check_variable_is_bound env set_of_closures;
ignore_closure_id closure_id
| Move_within_set_of_closures { closure; start_from; move_to; } ->
check_variable_is_bound env closure;
ignore_closure_id start_from;
ignore_closure_id move_to;
| Project_var { closure; closure_id; var; } ->
check_variable_is_bound env closure;
ignore_closure_id closure_id;
ignore_var_within_closure var
| Prim (prim, args, dbg) ->
ignore_primitive prim;
check_variables_are_bound env args;
ignore_debuginfo dbg
| Expr expr ->
loop env expr
and loop_set_of_closures env
({ Flambda.function_decls; free_vars; specialised_args; }
as set_of_closures) =
let { Flambda.set_of_closures_id; funs; } = function_decls in
ignore_set_of_closures_id set_of_closures_id;
let functions_in_closure = Variable.Map.keys funs in
let variables_in_closure =
Variable.Map.fold (fun var var_in_closure variables_in_closure ->
(* [var] may occur in the body, but will effectively be renamed
to [var_in_closure], so the latter is what we check to make
sure it's bound. *)
ignore_variable var;
check_variable_is_bound env var_in_closure;
Variable.Set.add var variables_in_closure)
free_vars Variable.Set.empty
in
let all_params, all_free_vars =
Variable.Map.fold (fun fun_var function_decl acc ->
let all_params, all_free_vars = acc in
(* CR-soon mshinwell: check function_decl.all_symbols *)
let { Flambda.params; body; free_variables; stub; dbg; _ } =
function_decl
in
assert (Variable.Set.mem fun_var functions_in_closure);
ignore_bool stub;
ignore_debuginfo dbg;
(* Check that [free_variables], which is only present as an
optimization, is not lying. *)
let free_variables' = Flambda.free_variables body in
if not (Variable.Set.subset free_variables' free_variables) then
raise (Free_variables_set_is_lying (fun_var,
free_variables, free_variables', function_decl));
(* Check that every variable free in the body of the function is
bound by either the set of closures or the parameter list. *)
let acceptable_free_variables =
Variable.Set.union
(Variable.Set.union variables_in_closure functions_in_closure)
(Variable.Set.of_list params)
in
let bad =
Variable.Set.diff free_variables acceptable_free_variables
in
if not (Variable.Set.is_empty bad) then begin
raise (Vars_in_function_body_not_bound_by_closure_or_params
(bad, set_of_closures, fun_var))
end;
(* Check that parameters are unique across all functions in the
declaration. *)
let old_all_params_size = Variable.Set.cardinal all_params in
let params = Variable.Set.of_list params in
let params_size = Variable.Set.cardinal params in
let all_params = Variable.Set.union all_params params in
let all_params_size = Variable.Set.cardinal all_params in
if all_params_size <> old_all_params_size + params_size then begin
raise (Function_decls_have_overlapping_parameters all_params)
end;
(* Check that parameters and function variables are not
bound somewhere else in the program *)
declare_variables params;
declare_variable fun_var;
(* Check that the body of the functions is correctly structured *)
let body_env =
let (var_env, _, sym_env) = env in
let var_env =
Variable.Set.fold (fun var -> Variable.Set.add var)
free_variables var_env
in
(* Mutable variables cannot be captured by closures *)
let mut_env = Mutable_variable.Set.empty in
(var_env, mut_env, sym_env)
in
loop body_env body;
all_params, Variable.Set.union free_variables all_free_vars)
funs (Variable.Set.empty, Variable.Set.empty)
in
(* CR-soon pchambart: This is not a property that we can certainly
ensure.
If the function get inlined, it is possible for the inlined version
to still use that variable. To be able to ensure that, we need to
also ensure that the inlined version will certainly be transformed
in a same way that can drop the dependency.
mshinwell: This should get some thought after the first release to
decide for sure what to do. *)
(* Check that the free variables rewriting map in the set of closures
does not contain variables in its domain that are not actually free
variables of any of the function bodies. *)
let bad_free_vars =
Variable.Set.diff (Variable.Map.keys free_vars) all_free_vars
in
(*
if not (Variable.Set.is_empty bad_free_vars) then begin
raise (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars)
end;
*)
(* Ignore it to avoid the warning: TODO get rid of that when the
case is settled *)
ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars);
(* Check that free variables variables are not bound somewhere
else in the program *)
declare_variables (Variable.Map.keys free_vars);
(* Check that every "specialised arg" is a parameter of one of the
functions being declared, and that the variable to which the
parameter is being specialised is bound. *)
Variable.Map.iter (fun being_specialised specialised_to ->
if not (Variable.Set.mem being_specialised all_params) then begin
raise (Specialised_arg_that_is_not_a_parameter being_specialised)
end;
check_variable_is_bound env specialised_to)
specialised_args
in
let loop_constant_defining_value env (const : Flambda.constant_defining_value) =
match const with
| Flambda.Allocated_const c ->
ignore_allocated_const c
| Flambda.Block (tag,fields) ->
ignore_tag tag;
List.iter (fun (fields : Flambda.constant_defining_value_block_field) ->
match fields with
| Const c -> ignore_const c
| Symbol s -> check_symbol_is_bound env s)
fields
| Flambda.Set_of_closures set_of_closures ->
loop_set_of_closures env set_of_closures;
(* Constant set of closures must not have free variables *)
if not (Variable.Map.is_empty set_of_closures.free_vars) then
assert false; (* TODO: correct error *)
if not (Variable.Map.is_empty set_of_closures.specialised_args) then
assert false; (* TODO: correct error *)
| Flambda.Project_closure (symbol,closure_id) ->
ignore_closure_id closure_id;
check_symbol_is_bound env symbol
in
let rec loop_program_body env (program : Flambda.program_body) =
match program with
| Let_rec_symbol (defs, program) ->
let env =
List.fold_left (fun env (symbol, _) ->
add_binding_occurrence_of_symbol env symbol)
env defs
in
List.iter (fun (_, def) ->
loop_constant_defining_value env def)
defs;
loop_program_body env program
| Let_symbol (symbol, def, program) ->
loop_constant_defining_value env def;
let env = add_binding_occurrence_of_symbol env symbol in
loop_program_body env program
| Initialize_symbol (symbol, _tag, fields, program) ->
List.iter (loop env) fields;
let env = add_binding_occurrence_of_symbol env symbol in
loop_program_body env program
| Effect (expr, program) ->
loop env expr;
loop_program_body env program
| End root ->
check_symbol_is_bound env root
in
let env =
Symbol.Set.fold (fun symbol env ->
add_binding_occurrence_of_symbol env symbol)
program.imported_symbols
(Variable.Set.empty, Mutable_variable.Set.empty, Symbol.Set.empty)
in
loop_program_body env program.program_body
let primitive_invariants flam ~no_access_to_global_module_identifiers =
Flambda_iterators.iter_named (function
| Prim (prim, _, _) ->
begin match prim with
| Psequand | Psequor ->
raise (Sequential_logical_operator_primitives_must_be_expanded prim)
| Pgetglobal id ->
if no_access_to_global_module_identifiers
&& not (Ident.is_predef_exn id) then
begin
raise (Access_to_global_module_identifier prim)
end
| Pidentity -> raise Pidentity_should_not_occur
| Pdirapply _ -> raise Pdirapply_should_be_expanded
| Prevapply _ -> raise Prevapply_should_be_expanded
| _ -> ()
end
| _ -> ())
flam
let declared_var_within_closure (flam:Flambda.program) =
let bound = ref Var_within_closure.Set.empty in
let bound_multiple_times = ref None in
let add_and_check var =
if Var_within_closure.Set.mem var !bound then begin
bound_multiple_times := Some var
end;
bound := Var_within_closure.Set.add var !bound
in
Flambda_iterators.iter_on_set_of_closures_of_program
~f:(fun ~constant:_ { Flambda. free_vars; _ } ->
Variable.Map.iter (fun id _ ->
let var = Var_within_closure.wrap id in
add_and_check var)
free_vars)
flam;
!bound, !bound_multiple_times
let no_var_within_closure_is_bound_multiple_times (flam:Flambda.program) =
match declared_var_within_closure flam with
| _, Some var -> raise (Var_within_closure_bound_multiple_times var)
| _, None -> ()
let every_declared_closure_is_from_current_compilation_unit flam =
let current_compilation_unit = Compilation_unit.get_current_exn () in
Flambda_iterators.iter_on_sets_of_closures (fun
{ Flambda. function_decls; _ } ->
let compilation_unit =
Set_of_closures_id.get_compilation_unit
function_decls.set_of_closures_id
in
if not (Compilation_unit.equal compilation_unit current_compilation_unit)
then raise (Declared_closure_from_another_unit compilation_unit))
flam
let declared_closure_ids program =
let bound = ref Closure_id.Set.empty in
let bound_multiple_times = ref None in
let add_and_check var =
if Closure_id.Set.mem var !bound
then bound_multiple_times := Some var;
bound := Closure_id.Set.add var !bound
in
Flambda_iterators.iter_on_set_of_closures_of_program program
~f:(fun ~constant:_ { Flambda. function_decls; _; } ->
Variable.Map.iter (fun id _ ->
let var = Closure_id.wrap id in
add_and_check var)
function_decls.funs);
!bound, !bound_multiple_times
let no_closure_id_is_bound_multiple_times program =
match declared_closure_ids program with
| _, Some closure_id ->
raise (Closure_id_is_bound_multiple_times closure_id)
| _, None -> ()
let declared_set_of_closures_ids program =
let bound = ref Set_of_closures_id.Set.empty in
let bound_multiple_times = ref None in
let add_and_check var =
if Set_of_closures_id.Set.mem var !bound
then bound_multiple_times := Some var;
bound := Set_of_closures_id.Set.add var !bound
in
Flambda_iterators.iter_on_set_of_closures_of_program program
~f:(fun ~constant:_ { Flambda. function_decls; _; } ->
add_and_check function_decls.set_of_closures_id);
!bound, !bound_multiple_times
let no_set_of_closures_id_is_bound_multiple_times program =
match declared_set_of_closures_ids program with
| _, Some set_of_closures_id ->
raise (Set_of_closures_id_is_bound_multiple_times set_of_closures_id)
| _, None -> ()
let used_closure_ids (program:Flambda.program) =
let used = ref Closure_id.Set.empty in
let f (flam : Flambda.named) =
match flam with
| Project_closure { closure_id; _} ->
used := Closure_id.Set.add closure_id !used;
| Move_within_set_of_closures { closure = _; start_from; move_to; } ->
used := Closure_id.Set.add start_from !used;
used := Closure_id.Set.add move_to !used
| Project_var { closure = _; closure_id; var = _ } ->
used := Closure_id.Set.add closure_id !used
| Set_of_closures _ | Symbol _ | Const _ | Allocated_const _
| Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _ -> ()
in
(* TODO: check closure_ids of constant_defining_values project_closures *)
Flambda_iterators.iter_named_of_program ~f program;
!used
let used_vars_within_closures (flam:Flambda.program) =
let used = ref Var_within_closure.Set.empty in
let f (flam : Flambda.named) =
match flam with
| Project_var { closure = _; closure_id = _; var; } ->
used := Var_within_closure.Set.add var !used
| _ -> ()
in
Flambda_iterators.iter_named_of_program ~f flam;
!used
let every_used_function_from_current_compilation_unit_is_declared (program:Flambda.program) =
let current_compilation_unit = Compilation_unit.get_current_exn () in
let declared, _ = declared_closure_ids program in
let used = used_closure_ids program in
let used_from_current_unit =
Closure_id.Set.filter (fun cu ->
Closure_id.in_compilation_unit cu current_compilation_unit)
used
in
let counter_examples =
Closure_id.Set.diff used_from_current_unit declared
in
if Closure_id.Set.is_empty counter_examples
then ()
else raise (Unbound_closure_ids counter_examples)
let every_used_var_within_closure_from_current_compilation_unit_is_declared
(flam:Flambda.program) =
let current_compilation_unit = Compilation_unit.get_current_exn () in
let declared, _ = declared_var_within_closure flam in
let used = used_vars_within_closures flam in
let used_from_current_unit =
Var_within_closure.Set.filter (fun cu ->
Var_within_closure.in_compilation_unit cu current_compilation_unit)
used
in
let counter_examples =
Var_within_closure.Set.diff used_from_current_unit declared in
if Var_within_closure.Set.is_empty counter_examples
then ()
else raise (Unbound_vars_within_closures counter_examples)
let every_static_exception_is_caught flam =
let check env (flam : Flambda.t) =
match flam with
| Static_raise (exn, _) ->
if not (Static_exception.Set.mem exn env)
then raise (Static_exception_not_caught exn)
| _ -> ()
in
let rec loop env (flam : Flambda.t) =
match flam with
| Static_catch (i, _, body, handler) ->
let env = Static_exception.Set.add i env in
loop env handler;
loop env body
| exp ->
check env exp;
Flambda_iterators.apply_on_subexpressions (loop env)
(fun (_ : Flambda.named) -> ()) exp
in
loop Static_exception.Set.empty flam
let every_static_exception_is_caught_at_a_single_position flam =
let caught = ref Static_exception.Set.empty in
let f (flam : Flambda.t) =
match flam with
| Static_catch (i, _, _body, _handler) ->
if Static_exception.Set.mem i !caught then
raise (Static_exception_caught_in_multiple_places i);
caught := Static_exception.Set.add i !caught
| _ -> ()
in
Flambda_iterators.iter f (fun (_ : Flambda.named) -> ()) flam
let check_exn ?(kind=Normal) ?(cmxfile=false) (flam:Flambda.program) =
ignore kind;
try
variable_and_symbol_invariants flam;
no_closure_id_is_bound_multiple_times flam;
no_set_of_closures_id_is_bound_multiple_times flam;
every_used_function_from_current_compilation_unit_is_declared flam;
no_var_within_closure_is_bound_multiple_times flam;
every_used_var_within_closure_from_current_compilation_unit_is_declared flam;
Flambda_iterators.iter_exprs_at_toplevel_of_program flam ~f:(fun flam ->
primitive_invariants flam ~no_access_to_global_module_identifiers:cmxfile;
every_static_exception_is_caught flam;
every_static_exception_is_caught_at_a_single_position flam;
every_declared_closure_is_from_current_compilation_unit flam)
with exn -> begin
(* CR-someday split printing code into its own function *)
begin match exn with
| Binding_occurrence_not_from_current_compilation_unit var ->
Format.eprintf ">> Binding occurrence of variable marked as not being \
from the current compilation unit: %a"
Variable.print var
| Mutable_binding_occurrence_not_from_current_compilation_unit mut_var ->
Format.eprintf ">> Binding occurrence of mutable variable marked as not \
being from the current compilation unit: %a"
Mutable_variable.print mut_var
| Binding_occurrence_of_variable_already_bound var ->
Format.eprintf ">> Binding occurrence of variable that was already \
bound: %a"
Variable.print var
| Binding_occurrence_of_mutable_variable_already_bound mut_var ->
Format.eprintf ">> Binding occurrence of mutable variable that was already \
bound: %a"
Mutable_variable.print mut_var
| Binding_occurrence_of_symbol_already_bound sym ->
Format.eprintf ">> Binding occurrence of symbol that was already \
bound: %a"
Symbol.print sym
| Unbound_variable var ->
Format.eprintf ">> Unbound variable: %a" Variable.print var
| Unbound_mutable_variable mut_var ->
Format.eprintf ">> Unbound mutable variable: %a"
Mutable_variable.print mut_var
| Unbound_symbol sym ->
Format.eprintf ">> Unbound symbol: %a %s" Symbol.print sym (Printexc.raw_backtrace_to_string (Printexc.get_callstack 100))
| Vars_in_function_body_not_bound_by_closure_or_params
(vars, set_of_closures, fun_var) ->
Format.eprintf ">> Variable(s) (%a) in the body of a function declaration \
(fun_var = %a) that is not bound by either the closure or the function's \
parameter list. Set of closures: %a"
Variable.Set.print vars
Variable.print fun_var
Flambda.print_set_of_closures set_of_closures
| Function_decls_have_overlapping_parameters vars ->
Format.eprintf ">> Function declarations whose parameters overlap: \
%a"
Variable.Set.print vars
| Specialised_arg_that_is_not_a_parameter var ->
Format.eprintf ">> Variable in [specialised_args] that is not a \
parameter of any of the function(s) in the corresponding \
declaration(s): %a"
Variable.print var
| Free_variables_set_is_lying (var, claimed, calculated, function_decl) ->
Format.eprintf ">> Function declaration whose [free_variables] set (%a) \
is not a superset of the result of [Flambda.free_variables] \
applied to the body of the function (%a). Declaration: %a"
Variable.Set.print claimed
Variable.Set.print calculated
Flambda.print_function_declaration (var, function_decl)
| Set_of_closures_free_vars_map_has_wrong_range vars ->
Format.eprintf ">> [free_vars] map in set of closures has in its range \
variables that are not free variables of the corresponding \
functions: %a"
Variable.Set.print vars
| Sequential_logical_operator_primitives_must_be_expanded prim ->
Format.eprintf ">> Sequential logical operator primitives must be \
expanded (see closure_conversion.ml): %a"
Printlambda.primitive prim
| Var_within_closure_bound_multiple_times var ->
Format.eprintf ">> Variable within a closure is bound multiple times: \
%a"
Var_within_closure.print var
| Closure_id_is_bound_multiple_times closure_id ->
Format.eprintf ">> Closure ID is bound multiple times: %a"
Closure_id.print closure_id
| Set_of_closures_id_is_bound_multiple_times set_of_closures_id ->
Format.eprintf ">> Set of closures ID is bound multiple times: %a"
Set_of_closures_id.print set_of_closures_id
| Declared_closure_from_another_unit compilation_unit ->
Format.eprintf ">> Closure declared as being from another compilation \
unit: %a"
Compilation_unit.print compilation_unit
| Unbound_closure_ids closure_ids ->
Format.eprintf ">> Unbound closure ID(s) from the current compilation \
unit: %a"
Closure_id.Set.print closure_ids
| Unbound_vars_within_closures vars_within_closures ->
Format.eprintf ">> Unbound variable(s) within closure(s) from the \
current compilation_unit: %a"
Var_within_closure.Set.print vars_within_closures
| Static_exception_not_caught static_exn ->
Format.eprintf ">> Uncaught static exception: %a"
Static_exception.print static_exn
| Static_exception_caught_in_multiple_places static_exn ->
Format.eprintf ">> Static exception caught in multiple places: %a"
Static_exception.print static_exn
| Access_to_global_module_identifier prim ->
(* CR-someday mshinwell: backend-specific checks should move to another
module, in the asmcomp/ directory. *)
Format.eprintf ">> Forbidden access to a global module identifier (not \
allowed in Flambda that will be exported to a .cmx file): %a"
Printlambda.primitive prim
| Pidentity_should_not_occur ->
Format.eprintf ">> The Pidentity primitive should never occur in an \
Flambda expression (see closure_conversion.ml)"
| Pdirapply_should_be_expanded ->
Format.eprintf ">> The Pdirapply primitive should never occur in an \
Flambda expression (see closure_conversion.ml); use Apply instead"
| Prevapply_should_be_expanded ->
Format.eprintf ">> The Prevapply primitive should never occur in an \
Flambda expression (see closure_conversion.ml); use Apply instead"
| exn -> raise exn
end;
Format.eprintf "\n@?";
raise Flambda_invariants_failed
end

27
middle_end/flambda_invariants.mli Normal file
View File

@ -0,0 +1,27 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
type flambda_kind =
| Normal
| Lifted
(** Checking of invariants on Flambda expressions. Raises an exception if
a check fails. *)
val check_exn
: ?kind:flambda_kind
-> ?cmxfile:bool
-> Flambda.program
-> unit

825
middle_end/flambda_iterators.ml Normal file
View File

@ -0,0 +1,825 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 apply_on_subexpressions f f_named (flam : Flambda.t) =
match flam with
| Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable
| Static_raise _ -> ()
| Let { defining_expr; body; _ } ->
f_named defining_expr;
f body
| Let_mutable (_mut_var, _var, body) ->
f body
| Let_rec (defs, body) ->
List.iter (fun (_,l) -> f_named l) defs;
f body
| Switch (_, sw) ->
List.iter (fun (_,l) -> f l) sw.consts;
List.iter (fun (_,l) -> f l) sw.blocks;
Misc.may f sw.failaction
| String_switch (_, sw, def) ->
List.iter (fun (_,l) -> f l) sw;
Misc.may f def
| Static_catch (_,_,f1,f2) ->
f f1; f f2;
| Try_with (f1,_,f2) ->
f f1; f f2
| If_then_else (_,f1, f2) ->
f f1;f f2
| While (f1,f2) ->
f f1; f f2
| For { body; _ } -> f body
let rec list_map_sharing f l =
match l with
| [] -> l
| h :: t ->
let new_t = list_map_sharing f t in
let new_h = f h in
if h == new_h && t == new_t then
l
else
new_h :: new_t
let may_map_sharing f v =
match v with
| None -> v
| Some s ->
let new_s = f s in
if s == new_s then
v
else
Some new_s
let map_snd_sharing f ((a, b) as cpl) =
let new_b = f a b in
if b == new_b then
cpl
else
(a, new_b)
let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t =
match tree with
| Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable
| Static_raise _ -> tree
| Let { var; defining_expr; body; _ } ->
let new_named = f_named var defining_expr in
let new_body = f body in
if new_named == defining_expr && new_body == body then
tree
else
Flambda.create_let var new_named new_body
| Let_rec (defs, body) ->
let new_defs =
list_map_sharing (map_snd_sharing f_named) defs
in
let new_body = f body in
if new_defs == defs && new_body == body then
tree
else
Let_rec (new_defs, new_body)
| Let_mutable (mut_var, var, body) ->
let new_body = f body in
if new_body == body then
tree
else
Let_mutable (mut_var, var, new_body)
| Switch (arg, sw) ->
let aux = map_snd_sharing (fun _ v -> f v) in
let new_consts = list_map_sharing aux sw.consts in
let new_blocks = list_map_sharing aux sw.blocks in
let new_failaction = may_map_sharing f sw.failaction in
if sw.failaction == new_failaction &&
new_consts == sw.consts &&
new_blocks == sw.blocks then
tree
else
let sw =
{ sw with
failaction = new_failaction;
consts = new_consts;
blocks = new_blocks;
}
in
Switch (arg, sw)
| String_switch (arg, sw, def) ->
let new_sw = list_map_sharing (map_snd_sharing (fun _ v -> f v)) sw in
let new_def = may_map_sharing f def in
if sw == new_sw && def == new_def then
tree
else
String_switch(arg, new_sw, new_def)
| Static_catch (i, vars, body, handler) ->
let new_body = f body in
let new_handler = f handler in
if new_body == body && new_handler == handler then
tree
else
Static_catch (i, vars, new_body, new_handler)
| Try_with(body, id, handler) ->
let new_body = f body in
let new_handler = f handler in
if body == new_body && handler == new_handler then
tree
else
Try_with(new_body, id, new_handler)
| If_then_else(arg, ifso, ifnot) ->
let new_ifso = f ifso in
let new_ifnot = f ifnot in
if new_ifso == ifso && new_ifnot == ifnot then
tree
else
If_then_else(arg, new_ifso, new_ifnot)
| While(cond, body) ->
let new_cond = f cond in
let new_body = f body in
if new_cond == cond && new_body == body then
tree
else
While(new_cond, new_body)
| For { bound_var; from_value; to_value; direction; body; } ->
let new_body = f body in
if new_body == body then
tree
else
For { bound_var; from_value; to_value; direction; body = new_body; }
let iter_general = Flambda.iter_general
let iter f f_named t = iter_general ~toplevel:false f f_named (Is_expr t)
let iter_expr f t = iter f (fun _ -> ()) t
let iter_on_named f f_named t =
iter_general ~toplevel:false f f_named (Is_named t)
let iter_named f_named t = iter (fun (_ : Flambda.t) -> ()) f_named t
let iter_named_on_named f_named named =
iter_general ~toplevel:false (fun (_ : Flambda.t) -> ()) f_named
(Is_named named)
let iter_toplevel f f_named t = iter_general ~toplevel:true f f_named (Is_expr t)
let iter_named_toplevel f f_named named =
iter_general ~toplevel:true f f_named (Is_named named)
let iter_all_immutable_let_and_let_rec_bindings t ~f =
iter_expr (function
| Let { var; defining_expr; _ } -> f var defining_expr
| Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs
| _ -> ())
t
let iter_all_toplevel_immutable_let_and_let_rec_bindings t ~f =
iter_general ~toplevel:true
(function
| Let { var; defining_expr; _ } -> f var defining_expr
| Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs
| _ -> ())
(fun _ -> ())
(Is_expr t)
let iter_on_sets_of_closures f t =
iter_named (function
| Set_of_closures clos -> f clos
| Symbol _ | Const _ | Allocated_const _ | Read_mutable _
| Read_symbol_field _
| Project_closure _ | Move_within_set_of_closures _ | Project_var _
| Prim _ | Expr _ -> ())
t
let iter_exprs_at_toplevel_of_program (program : Flambda.program) ~f =
let rec loop (program : Flambda.program_body) =
match program with
| Let_symbol (_, Set_of_closures set_of_closures, program) ->
Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) ->
f function_decl.body)
set_of_closures.function_decls.funs;
loop program
| Let_rec_symbol (defs, program) ->
List.iter (function
| (_, Flambda.Set_of_closures set_of_closures) ->
Variable.Map.iter
(fun _ (function_decl : Flambda.function_declaration) ->
f function_decl.body)
set_of_closures.function_decls.funs
| _ -> ()) defs;
loop program
| Let_symbol (_, _, program) ->
loop program
| Initialize_symbol (_, _, fields, program) ->
List.iter f fields;
loop program
| Effect (expr, program) ->
f expr;
loop program
| End _ -> ()
in
loop program.program_body
let iter_named_of_program program ~f =
iter_exprs_at_toplevel_of_program program ~f:(iter_named f)
let iter_on_set_of_closures_of_program (program : Flambda.program) ~f =
let rec loop (program : Flambda.program_body) =
match program with
| Let_symbol (_, Set_of_closures set_of_closures, program) ->
f ~constant:true set_of_closures;
Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) ->
iter_on_sets_of_closures (f ~constant:false) function_decl.body)
set_of_closures.function_decls.funs;
loop program
| Let_rec_symbol (defs, program) ->
List.iter (function
| (_, Flambda.Set_of_closures set_of_closures) ->
f ~constant:true set_of_closures;
Variable.Map.iter
(fun _ (function_decl : Flambda.function_declaration) ->
iter_on_sets_of_closures (f ~constant:false) function_decl.body)
set_of_closures.function_decls.funs
| _ -> ()) defs;
loop program
| Let_symbol (_, _, program) ->
loop program
| Initialize_symbol (_, _, fields, program) ->
List.iter (iter_on_sets_of_closures (f ~constant:false)) fields;
loop program
| Effect (expr, program) ->
iter_on_sets_of_closures (f ~constant:false) expr;
loop program
| End _ -> ()
in
loop program.program_body
let iter_constant_defining_values_on_program (program : Flambda.program) ~f =
let rec loop (program : Flambda.program_body) =
match program with
| Let_symbol (_, const, program) ->
f const;
loop program
| Let_rec_symbol (defs, program) ->
List.iter (fun (_, const) -> f const) defs;
loop program
| Initialize_symbol (_, _, _, program) ->
loop program
| Effect (_, program) ->
loop program
| End _ -> ()
in
loop program.program_body
let map_general ~toplevel f f_named tree =
let rec aux (tree : Flambda.t) =
match tree with
| Let _ ->
Flambda.map_lets tree ~for_defining_expr:aux_named ~for_last_body:aux
~after_rebuild:f
| _ ->
let exp : Flambda.t =
match tree with
| Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable
| Static_raise _ -> tree
| Let _ -> assert false
| Let_mutable (mut_var, var, body) ->
let new_body = aux body in
if new_body == body then
tree
else
Let_mutable (mut_var, var, new_body)
| Let_rec (defs, body) ->
let done_something = ref false in
let defs =
List.map (fun (id, lam) ->
id, aux_named_done_something id lam done_something)
defs
in
let body = aux_done_something body done_something in
if not !done_something then
tree
else
Let_rec (defs, body)
| Switch (arg, sw) ->
let done_something = ref false in
let sw =
{ sw with
failaction =
begin match sw.failaction with
| None -> None
| Some failaction ->
Some (aux_done_something failaction done_something)
end;
consts =
List.map (fun (i, v) ->
i, aux_done_something v done_something)
sw.consts;
blocks =
List.map (fun (i, v) ->
i, aux_done_something v done_something)
sw.blocks;
}
in
if not !done_something then
tree
else
Switch (arg, sw)
| String_switch (arg, sw, def) ->
let done_something = ref false in
let sw =
List.map (fun (i, v) -> i, aux_done_something v done_something) sw
in
let def =
match def with
| None -> None
| Some def -> Some (aux_done_something def done_something)
in
if not !done_something then
tree
else
String_switch(arg, sw, def)
| Static_catch (i, vars, body, handler) ->
let new_body = aux body in
let new_handler = aux handler in
if new_body == body && new_handler == handler then
tree
else
Static_catch (i, vars, new_body, new_handler)
| Try_with(body, id, handler) ->
let new_body = aux body in
let new_handler = aux handler in
if new_body == body && new_handler == handler then
tree
else
Try_with (new_body, id, new_handler)
| If_then_else (arg, ifso, ifnot) ->
let new_ifso = aux ifso in
let new_ifnot = aux ifnot in
if new_ifso == ifso && new_ifnot == ifnot then
tree
else
If_then_else (arg, new_ifso, new_ifnot)
| While (cond, body) ->
let new_cond = aux cond in
let new_body = aux body in
if new_cond == cond && new_body == body then
tree
else
While (new_cond, new_body)
| For { bound_var; from_value; to_value; direction; body; } ->
let new_body = aux body in
if new_body == body then
tree
else
For { bound_var; from_value; to_value; direction;
body = new_body; }
in
f exp
and aux_done_something expr done_something =
let new_expr = aux expr in
if not (new_expr == expr) then begin
done_something := true
end;
new_expr
and aux_named (id : Variable.t) (named : Flambda.named) =
let named : Flambda.named =
match named with
| Symbol _ | Const _ | Allocated_const _ | Read_mutable _
| Project_closure _ | Move_within_set_of_closures _ | Project_var _
| Prim _ | Read_symbol_field _ -> named
| Set_of_closures ({ function_decls; free_vars; specialised_args }) ->
if toplevel then named
else begin
let done_something = ref false in
let funs =
Variable.Map.map (fun (func_decl : Flambda.function_declaration) ->
let new_body = aux func_decl.body in
if new_body == func_decl.body then begin
func_decl
end else begin
done_something := true;
Flambda.create_function_declaration
~params:func_decl.params
~body:new_body
~stub:func_decl.stub
~dbg:func_decl.dbg
~inline:func_decl.inline
~is_a_functor:func_decl.is_a_functor
end)
function_decls.funs
in
if not !done_something then
named
else
let function_decls =
Flambda.update_function_declarations function_decls ~funs
in
let set_of_closures =
Flambda.create_set_of_closures ~function_decls ~free_vars
~specialised_args
in
Set_of_closures set_of_closures
end
| Expr expr ->
let new_expr = aux expr in
if new_expr == expr then named
else Expr new_expr
in
f_named id named
and aux_named_done_something id named done_something =
let new_named = aux_named id named in
if not (new_named == named) then begin
done_something := true
end;
new_named
in
aux tree
let iter_apply_on_program program ~f =
iter_exprs_at_toplevel_of_program program ~f:(fun expr ->
iter (function
| Apply apply -> f apply
| _ -> ())
(fun _ -> ())
expr)
let map f f_named tree = map_general ~toplevel:false f (fun _ n -> f_named n) tree
let map_expr f tree = map f (fun named -> named) tree
let map_named f_named tree = map (fun expr -> expr) f_named tree
let map_named_with_id f_named tree =
map_general ~toplevel:false (fun expr -> expr) f_named tree
let map_toplevel f f_named tree =
map_general ~toplevel:true f (fun _ n -> f_named n) tree
let map_toplevel_expr f_expr tree =
map_toplevel f_expr (fun named -> named) tree
let map_toplevel_named f_named tree =
map_toplevel (fun tree -> tree) f_named tree
let map_symbols tree ~f =
map_named (function
| (Symbol sym) as named ->
let new_sym = f sym in
if new_sym == sym then
named
else
Symbol new_sym
| ((Read_symbol_field (sym, field)) as named) ->
let new_sym = f sym in
if new_sym == sym then
named
else
Read_symbol_field (new_sym, field)
| (Const _ | Allocated_const _ | Set_of_closures _ | Read_mutable _
| Project_closure _ | Move_within_set_of_closures _ | Project_var _
| Prim _ | Expr _) as named -> named)
tree
let map_symbols_on_set_of_closures
({ Flambda.function_decls; free_vars; specialised_args } as
set_of_closures)
~f =
let done_something = ref false in
let funs =
Variable.Map.map (fun (func_decl : Flambda.function_declaration) ->
let body = map_symbols func_decl.body ~f in
if not (body == func_decl.body) then begin
done_something := true;
end;
Flambda.create_function_declaration
~params:func_decl.params
~body
~stub:func_decl.stub
~dbg:func_decl.dbg
~inline:func_decl.inline
~is_a_functor:func_decl.is_a_functor)
function_decls.funs
in
if not !done_something then
set_of_closures
else
let function_decls =
Flambda.update_function_declarations function_decls ~funs
in
Flambda.create_set_of_closures ~function_decls ~free_vars
~specialised_args
let map_toplevel_sets_of_closures tree ~f =
map_toplevel_named (function
| (Set_of_closures set_of_closures) as named ->
let new_set_of_closures = f set_of_closures in
if new_set_of_closures == set_of_closures then
named
else
Set_of_closures new_set_of_closures
| (Symbol _ | Const _ | Allocated_const _ | Read_mutable _
| Read_symbol_field _
| Project_closure _ | Move_within_set_of_closures _ | Project_var _
| Prim _ | Expr _) as named -> named)
tree
let map_apply tree ~f =
map (function
| (Apply apply) as expr ->
let new_apply = f apply in
if new_apply == apply then
expr
else
Apply new_apply
| expr -> expr)
(fun named -> named)
tree
let map_sets_of_closures tree ~f =
map_named (function
| (Set_of_closures set_of_closures) as named ->
let new_set_of_closures = f set_of_closures in
if new_set_of_closures == set_of_closures then
named
else
Set_of_closures new_set_of_closures
| (Symbol _ | Const _ | Allocated_const _ | Project_closure _
| Move_within_set_of_closures _ | Project_var _
| Prim _ | Expr _ | Read_mutable _
| Read_symbol_field _) as named -> named)
tree
let map_project_var_to_expr_opt tree ~f =
map_named (function
| (Project_var project_var) as named ->
begin match f project_var with
| None -> named
| Some expr -> Expr expr
end
| (Symbol _ | Const _ | Allocated_const _
| Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _
| Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _)
as named -> named)
tree
let map_toplevel_project_var_to_expr_opt tree ~f =
map_toplevel_named (function
| (Project_var project_var) as named ->
begin match f project_var with
| None -> named
| Some expr -> Expr expr
end
| (Symbol _ | Const _ | Allocated_const _
| Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _
| Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _)
as named -> named)
tree
let map_project_var_to_named_opt tree ~f =
map_named (function
| (Project_var project_var) as named ->
begin match f project_var with
| None -> named
| Some named -> named
end
| (Symbol _ | Const _ | Allocated_const _
| Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _
| Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _)
as named -> named)
tree
let map_function_bodies (set_of_closures : Flambda.set_of_closures) ~f =
let done_something = ref false in
let funs =
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
let new_body = f function_decl.body in
if new_body == function_decl.body then
function_decl
else begin
done_something := true;
Flambda.create_function_declaration ~body:new_body
~params:function_decl.params
~stub:function_decl.stub
~dbg:function_decl.dbg
~inline:function_decl.inline
~is_a_functor:function_decl.is_a_functor
end)
set_of_closures.function_decls.funs
in
if not !done_something then
set_of_closures
else
let function_decls =
Flambda.update_function_declarations set_of_closures.function_decls ~funs
in
Flambda.create_set_of_closures
~function_decls
~free_vars:set_of_closures.free_vars
~specialised_args:set_of_closures.specialised_args
let map_sets_of_closures_of_program (program : Flambda.program)
~(f : Flambda.set_of_closures -> Flambda.set_of_closures) =
let rec loop (program : Flambda.program_body) : Flambda.program_body =
let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) =
let done_something = ref false in
let function_decls =
let funs =
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
let body = map_sets_of_closures ~f function_decl.body in
if body == function_decl.body then
function_decl
else begin
done_something := true;
Flambda.create_function_declaration ~body
~params:function_decl.params
~stub:function_decl.stub
~dbg:function_decl.dbg
~inline:function_decl.inline
~is_a_functor:function_decl.is_a_functor
end)
set_of_closures.function_decls.funs
in
if not !done_something then
set_of_closures.function_decls
else
Flambda.update_function_declarations set_of_closures.function_decls
~funs
in
let new_set_of_closures = f set_of_closures in
if new_set_of_closures == set_of_closures then
set_of_closures
else
Flambda.create_set_of_closures ~function_decls
~free_vars:set_of_closures.free_vars
~specialised_args:set_of_closures.specialised_args
in
match program with
| Let_symbol (symbol, Set_of_closures set_of_closures, program') ->
let new_set_of_closures = map_constant_set_of_closures set_of_closures in
let new_program' = loop program' in
if new_set_of_closures == set_of_closures
&& new_program' == program' then
program
else
Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program')
| Let_symbol (symbol, const, program') ->
let new_program' = loop program' in
if new_program' == program' then
program
else
Let_symbol (symbol, const, new_program')
| Let_rec_symbol (defs, program') ->
let done_something = ref false in
let defs =
List.map (function
| (var, Flambda.Set_of_closures set_of_closures) ->
let new_set_of_closures =
map_constant_set_of_closures set_of_closures
in
if not (new_set_of_closures == set_of_closures) then begin
done_something := true
end;
var, Flambda.Set_of_closures new_set_of_closures
| def -> def)
defs
in
let new_program' = loop program' in
if new_program' == program' && not !done_something then
program
else
Let_rec_symbol (defs, loop program')
| Initialize_symbol (symbol, tag, fields, program') ->
let done_something = ref false in
let fields =
List.map (fun field ->
let new_field = map_sets_of_closures field ~f in
if not (new_field == field) then begin
done_something := true
end;
new_field)
fields
in
let new_program' = loop program' in
if new_program' == program' && not !done_something then
program
else
Initialize_symbol (symbol, tag, fields, new_program')
| Effect (expr, program') ->
let new_expr = map_sets_of_closures expr ~f in
let new_program' = loop program' in
if new_expr == expr && new_program' == program' then
program
else
Effect (new_expr, new_program')
| End _ -> program
in
{ program with
program_body = loop program.program_body;
}
let map_exprs_at_toplevel_of_program (program : Flambda.program)
~(f : Flambda.t -> Flambda.t) =
let rec loop (program : Flambda.program_body) : Flambda.program_body =
let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) =
let done_something = ref false in
let funs =
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
let body = f function_decl.body in
if body == function_decl.body then
function_decl
else begin
done_something := true;
Flambda.create_function_declaration ~body
~params:function_decl.params
~stub:function_decl.stub
~dbg:function_decl.dbg
~inline:function_decl.inline
~is_a_functor:function_decl.is_a_functor
end)
set_of_closures.function_decls.funs
in
if not !done_something then
set_of_closures
else
let function_decls =
Flambda.update_function_declarations set_of_closures.function_decls
~funs
in
Flambda.create_set_of_closures ~function_decls
~free_vars:set_of_closures.free_vars
~specialised_args:set_of_closures.specialised_args
in
(* CR-soon mshinwell: code very similar to the above function *)
match program with
| Let_symbol (symbol, Set_of_closures set_of_closures, program') ->
let new_set_of_closures = map_constant_set_of_closures set_of_closures in
let new_program' = loop program' in
if new_set_of_closures == set_of_closures
&& new_program' == program' then
program
else
Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program')
| Let_symbol (symbol, const, program') ->
let new_program' = loop program' in
if new_program' == program' then
program
else
Let_symbol (symbol, const, new_program')
| Let_rec_symbol (defs, program') ->
let done_something = ref false in
let defs =
List.map (function
| (var, Flambda.Set_of_closures set_of_closures) ->
let new_set_of_closures =
map_constant_set_of_closures set_of_closures
in
if not (new_set_of_closures == set_of_closures) then begin
done_something := true
end;
var, Flambda.Set_of_closures new_set_of_closures
| def -> def)
defs
in
let new_program' = loop program' in
if new_program' == program' && not !done_something then
program
else
Let_rec_symbol (defs, new_program')
| Initialize_symbol (symbol, tag, fields, program') ->
let done_something = ref false in
let fields =
List.map (fun field ->
let new_field = f field in
if not (new_field == field) then begin
done_something := true
end;
new_field)
fields
in
let new_program' = loop program' in
if new_program' == program' && not !done_something then
program
else
Initialize_symbol (symbol, tag, fields, new_program')
| Effect (expr, program') ->
let new_expr = f expr in
let new_program' = loop program' in
if new_expr == expr && new_program' == program' then
program
else
Effect (new_expr, new_program')
| End _ -> program
in
{ program with
program_body = loop program.program_body;
}
let map_named_of_program (program : Flambda.program)
~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.program =
map_exprs_at_toplevel_of_program program
~f:(fun expr -> map_named_with_id f expr)
let map_all_immutable_let_and_let_rec_bindings (expr : Flambda.t)
~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.t =
map_named_with_id f expr

221
middle_end/flambda_iterators.mli Normal file
View File

@ -0,0 +1,221 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(* CR-soon mshinwell: we need to document whether these iterators follow any
particular order. *)
(** Apply the given functions to the immediate subexpressions of the given
Flambda expression. For avoidance of doubt, if a subexpression is
[Expr], it is passed to the function taking [Flambda.named], rather
than being followed and passed to the function taking [Flambda.t]. *)
val apply_on_subexpressions
: (Flambda.t -> unit)
-> (Flambda.named -> unit)
-> Flambda.t
-> unit
val map_subexpressions
: (Flambda.t -> Flambda.t)
-> (Variable.t -> Flambda.named -> Flambda.named)
-> Flambda.t
-> Flambda.t
(* CR-soon lwhite: add comment to clarify that these recurse unlike the
ones above *)
val iter
: (Flambda.t -> unit)
-> (Flambda.named -> unit)
-> Flambda.t
-> unit
val iter_expr
: (Flambda.t -> unit)
-> Flambda.t
-> unit
val iter_on_named
: (Flambda.t -> unit)
-> (Flambda.named -> unit)
-> Flambda.named
-> unit
(* CR-someday mshinwell: we might need to add the corresponding variable to
the parameters of the user function for [iter_named] *)
val iter_named
: (Flambda.named -> unit)
-> Flambda.t
-> unit
(* CR-someday lwhite: These names are pretty indecipherable, perhaps
create submodules for the normal and "on_named" variants of each
function. *)
val iter_named_on_named
: (Flambda.named -> unit)
-> Flambda.named
-> unit
(** [iter_toplevel f t] applies [f] on every toplevel subexpression of [t].
In particular, it never applies [f] to the body of a function (which
will always be contained within an [Set_of_closures] expression). *)
val iter_toplevel
: (Flambda.t -> unit)
-> (Flambda.named -> unit)
-> Flambda.t
-> unit
val iter_named_toplevel
: (Flambda.t -> unit)
-> (Flambda.named -> unit)
-> Flambda.named
-> unit
val iter_on_sets_of_closures
: (Flambda.set_of_closures -> unit)
-> Flambda.t
-> unit
val iter_on_set_of_closures_of_program
: Flambda.program
-> f:(constant:bool -> Flambda.set_of_closures -> unit)
-> unit
val iter_all_immutable_let_and_let_rec_bindings
: Flambda.t
-> f:(Variable.t -> Flambda.named -> unit)
-> unit
val iter_all_toplevel_immutable_let_and_let_rec_bindings
: Flambda.t
-> f:(Variable.t -> Flambda.named -> unit)
-> unit
val iter_exprs_at_toplevel_of_program
: Flambda.program
-> f:(Flambda.t -> unit)
-> unit
val iter_named_of_program
: Flambda.program
-> f:(Flambda.named -> unit)
-> unit
val iter_constant_defining_values_on_program
: Flambda.program
-> f:(Flambda.constant_defining_value -> unit)
-> unit
val iter_apply_on_program
: Flambda.program
-> f:(Flambda.apply -> unit)
-> unit
val map
: (Flambda.t -> Flambda.t)
-> (Flambda.named -> Flambda.named)
-> Flambda.t
-> Flambda.t
val map_expr
: (Flambda.t -> Flambda.t)
-> Flambda.t
-> Flambda.t
val map_named
: (Flambda.named -> Flambda.named)
-> Flambda.t
-> Flambda.t
val map_toplevel
: (Flambda.t -> Flambda.t)
-> (Flambda.named -> Flambda.named)
-> Flambda.t
-> Flambda.t
val map_toplevel_expr
: (Flambda.t -> Flambda.t)
-> Flambda.t
-> Flambda.t
val map_toplevel_named
: (Flambda.named -> Flambda.named)
-> Flambda.t
-> Flambda.t
val map_symbols
: Flambda.t
-> f:(Symbol.t -> Symbol.t)
-> Flambda.t
val map_symbols_on_set_of_closures
: Flambda.set_of_closures
-> f:(Symbol.t -> Symbol.t)
-> Flambda.set_of_closures
val map_toplevel_sets_of_closures
: Flambda.t
-> f:(Flambda.set_of_closures -> Flambda.set_of_closures)
-> Flambda.t
val map_apply
: Flambda.t
-> f:(Flambda.apply -> Flambda.apply)
-> Flambda.t
val map_function_bodies
: Flambda.set_of_closures
-> f:(Flambda.t -> Flambda.t)
-> Flambda.set_of_closures
val map_sets_of_closures
: Flambda.t
-> f:(Flambda.set_of_closures -> Flambda.set_of_closures)
-> Flambda.t
val map_sets_of_closures_of_program
: Flambda.program
-> f:(Flambda.set_of_closures -> Flambda.set_of_closures)
-> Flambda.program
val map_project_var_to_expr_opt
: Flambda.t
-> f:(Flambda.project_var -> Flambda.t option)
-> Flambda.t
val map_toplevel_project_var_to_expr_opt
: Flambda.t
-> f:(Flambda.project_var -> Flambda.t option)
-> Flambda.t
val map_project_var_to_named_opt
: Flambda.t
-> f:(Flambda.project_var -> Flambda.named option)
-> Flambda.t
val map_exprs_at_toplevel_of_program
: Flambda.program
-> f:(Flambda.t -> Flambda.t)
-> Flambda.program
val map_named_of_program
: Flambda.program
-> f:(Variable.t -> Flambda.named -> Flambda.named)
-> Flambda.program
val map_all_immutable_let_and_let_rec_bindings
: Flambda.t
-> f:(Variable.t -> Flambda.named -> Flambda.named)
-> Flambda.t

754
middle_end/flambda_utils.ml Normal file
View File

@ -0,0 +1,754 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed 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 find_declaration cf ({ funs } : Flambda.function_declarations) =
Variable.Map.find (Closure_id.unwrap cf) funs
let find_declaration_variable cf ({ funs } : Flambda.function_declarations) =
let var = Closure_id.unwrap cf in
if not (Variable.Map.mem var funs)
then raise Not_found
else var
let find_free_variable cv ({ free_vars } : Flambda.set_of_closures) =
Variable.Map.find (Var_within_closure.unwrap cv) free_vars
let function_arity (f : Flambda.function_declaration) = List.length f.params
let variables_bound_by_the_closure cf
(decls : Flambda.function_declarations) =
let func = find_declaration cf decls in
let params = Variable.Set.of_list func.params in
let functions = Variable.Map.keys decls.funs in
Variable.Set.diff
(Variable.Set.diff func.free_variables params)
functions
let description_of_toplevel_node (expr : Flambda.t) =
match expr with
| Var id -> Format.asprintf "var %a" Variable.print id
| Apply _ -> "apply"
| Assign _ -> "assign"
| Send _ -> "send"
| Proved_unreachable -> "unreachable"
| Let { var; _ } -> Format.asprintf "let %a" Variable.print var
| Let_mutable _ -> "let_mutable"
| Let_rec _ -> "letrec"
| If_then_else _ -> "if"
| Switch _ -> "switch"
| String_switch _ -> "stringswitch"
| Static_raise _ -> "staticraise"
| Static_catch _ -> "catch"
| Try_with _ -> "trywith"
| While _ -> "while"
| For _ -> "for"
let compare_const (c1 : Flambda.const) (c2 : Flambda.const) =
match c1, c2 with
| Int v1, Int v2 -> compare v1 v2
| Char v1, Char v2 -> compare v1 v2
| Const_pointer v1, Const_pointer v2 -> compare v1 v2
| Int _, _ -> -1
| _, Int _ -> 1
| Char _, _ -> -1
| _, Char _ -> 1
let rec same (l1 : Flambda.t) (l2 : Flambda.t) =
l1 == l2 || (* it is ok for the string case: if they are physically the same,
it is the same original branch *)
match (l1, l2) with
| Var v1 , Var v2 -> Variable.equal v1 v2
| Var _, _ | _, Var _ -> false
| Apply a1 , Apply a2 ->
a1.kind = a2.kind
&& Variable.equal a1.func a2.func
&& Misc.samelist Variable.equal a1.args a2.args
| Apply _, _ | _, Apply _ -> false
| Let { var = var1; defining_expr = defining_expr1; body = body1; _ },
Let { var = var2; defining_expr = defining_expr2; body = body2; _ } ->
Variable.equal var1 var2 && same_named defining_expr1 defining_expr2
&& same body1 body2
| Let _, _ | _, Let _ -> false
| Let_mutable (mv1, v1, b1), Let_mutable (mv2, v2, b2) ->
Mutable_variable.equal mv1 mv2
&& Variable.equal v1 v2
&& same b1 b2
| Let_mutable _, _ | _, Let_mutable _ -> false
| Let_rec (bl1, a1), Let_rec (bl2, a2) ->
Misc.samelist samebinding bl1 bl2 && same a1 a2
| Let_rec _, _ | _, Let_rec _ -> false
| Switch (a1, s1), Switch (a2, s2) ->
Variable.equal a1 a2 && sameswitch s1 s2
| Switch _, _ | _, Switch _ -> false
| String_switch (a1, s1, d1), String_switch (a2, s2, d2) ->
Variable.equal a1 a2 &&
Misc.samelist (fun (s1, e1) (s2, e2) -> s1 = s2 && same e1 e2) s1 s2 &&
Misc.sameoption same d1 d2
| String_switch _, _ | _, String_switch _ -> false
| Static_raise (e1, a1), Static_raise (e2, a2) ->
Static_exception.equal e1 e2 && Misc.samelist Variable.equal a1 a2
| Static_raise _, _ | _, Static_raise _ -> false
| Static_catch (s1, v1, a1, b1), Static_catch (s2, v2, a2, b2) ->
Static_exception.equal s1 s2 && Misc.samelist Variable.equal v1 v2 &&
same a1 a2 && same b1 b2
| Static_catch _, _ | _, Static_catch _ -> false
| Try_with (a1, v1, b1), Try_with (a2, v2, b2) ->
same a1 a2 && Variable.equal v1 v2 && same b1 b2
| Try_with _, _ | _, Try_with _ -> false
| If_then_else (a1, b1, c1), If_then_else (a2, b2, c2) ->
Variable.equal a1 a2 && same b1 b2 && same c1 c2
| If_then_else _, _ | _, If_then_else _ -> false
| While (a1, b1), While (a2, b2) ->
same a1 a2 && same b1 b2
| While _, _ | _, While _ -> false
| For { bound_var = bound_var1; from_value = from_value1;
to_value = to_value1; direction = direction1; body = body1; },
For { bound_var = bound_var2; from_value = from_value2;
to_value = to_value2; direction = direction2; body = body2; } ->
Variable.equal bound_var1 bound_var2
&& Variable.equal from_value1 from_value2
&& Variable.equal to_value1 to_value2
&& direction1 = direction2
&& same body1 body2
| For _, _ | _, For _ -> false
| Assign { being_assigned = being_assigned1; new_value = new_value1; },
Assign { being_assigned = being_assigned2; new_value = new_value2; } ->
Mutable_variable.equal being_assigned1 being_assigned2
&& Variable.equal new_value1 new_value2
| Assign _, _ | _, Assign _ -> false
| Send { kind = kind1; meth = meth1; obj = obj1; args = args1; dbg = _; },
Send { kind = kind2; meth = meth2; obj = obj2; args = args2; dbg = _; } ->
kind1 = kind2
&& Variable.equal meth1 meth2
&& Variable.equal obj1 obj2
&& Misc.samelist Variable.equal args1 args2
| Send _, _ | _, Send _ -> false
| Proved_unreachable, Proved_unreachable -> true
and same_named (named1 : Flambda.named) (named2 : Flambda.named) =
match named1, named2 with
| Symbol s1 , Symbol s2 -> Symbol.equal s1 s2
| Symbol _, _ | _, Symbol _ -> false
| Const c1, Const c2 -> compare_const c1 c2 = 0
| Const _, _ | _, Const _ -> false
| Allocated_const c1, Allocated_const c2 ->
Allocated_const.compare c1 c2 = 0
| Allocated_const _, _ | _, Allocated_const _ -> false
| Read_mutable mv1, Read_mutable mv2 -> Mutable_variable.equal mv1 mv2
| Read_mutable _, _ | _, Read_mutable _ -> false
| Read_symbol_field (s1, i1), Read_symbol_field (s2, i2) ->
Symbol.equal s1 s2 && i1 = i2
| Read_symbol_field _, _ | _, Read_symbol_field _ -> false
| Set_of_closures s1, Set_of_closures s2 -> same_set_of_closures s1 s2
| Set_of_closures _, _ | _, Set_of_closures _ -> false
| Project_closure f1, Project_closure f2 -> same_project_closure f1 f2
| Project_closure _, _ | _, Project_closure _ -> false
| Project_var v1, Project_var v2 ->
Variable.equal v1.closure v2.closure
&& Closure_id.equal v1.closure_id v2.closure_id
&& Var_within_closure.equal v1.var v2.var
| Project_var _, _ | _, Project_var _ -> false
| Move_within_set_of_closures m1, Move_within_set_of_closures m2 ->
same_move_within_set_of_closures m1 m2
| Move_within_set_of_closures _, _ | _, Move_within_set_of_closures _ ->
false
| Prim (p1, al1, _), Prim (p2, al2, _) ->
p1 = p2 && Misc.samelist Variable.equal al1 al2
| Prim _, _ | _, Prim _ -> false
| Expr e1, Expr e2 -> same e1 e2
and sameclosure (c1 : Flambda.function_declaration)
(c2 : Flambda.function_declaration) =
Misc.samelist Variable.equal c1.params c2.params
&& same c1.body c2.body
and same_set_of_closures (c1 : Flambda.set_of_closures)
(c2 : Flambda.set_of_closures) =
Variable.Map.equal sameclosure c1.function_decls.funs c2.function_decls.funs
&& Variable.Map.equal Variable.equal c1.free_vars c2.free_vars
&& Variable.Map.equal Variable.equal c1.specialised_args
c2.specialised_args
and same_project_closure (s1 : Flambda.project_closure)
(s2 : Flambda.project_closure) =
Variable.equal s1.set_of_closures s2.set_of_closures
&& Closure_id.equal s1.closure_id s2.closure_id
and same_move_within_set_of_closures (m1 : Flambda.move_within_set_of_closures)
(m2 : Flambda.move_within_set_of_closures) =
Variable.equal m1.closure m2.closure
&& Closure_id.equal m1.start_from m2.start_from
&& Closure_id.equal m1.move_to m2.move_to
and samebinding (v1, n1) (v2, n2) =
Variable.equal v1 v2 && same_named n1 n2
and sameswitch (fs1 : Flambda.switch) (fs2 : Flambda.switch) =
let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in
fs1.numconsts = fs2.numconsts
&& fs1.numblocks = fs2.numblocks
&& Misc.samelist samecase fs1.consts fs2.consts
&& Misc.samelist samecase fs1.blocks fs2.blocks
&& Misc.sameoption same fs1.failaction fs2.failaction
let can_be_merged = same
(* CR-soon mshinwell: this should use the explicit ignore functions *)
let toplevel_substitution sb tree =
let sb' = sb in
let sb v = try Variable.Map.find v sb with Not_found -> v in
let aux (flam : Flambda.t) : Flambda.t =
match flam with
| Var var -> Var (sb var)
| Let_mutable (mut_var, var, body) ->
Let_mutable (mut_var, sb var, body)
| Assign { being_assigned; new_value; } ->
Assign { being_assigned; new_value = sb new_value; }
| Apply { func; args; kind; dbg; inline; } ->
Apply { func = sb func; args = List.map sb args; kind; dbg; inline; }
| If_then_else (cond, e1, e2) -> If_then_else (sb cond, e1, e2)
| Switch (cond, sw) -> Switch (sb cond, sw)
| String_switch (cond, branches, def) ->
String_switch (sb cond, branches, def)
| Send { kind; meth; obj; args; dbg } ->
Send { kind; meth = sb meth; obj = sb obj; args = List.map sb args; dbg }
| For { bound_var; from_value; to_value; direction; body } ->
For { bound_var; from_value = sb from_value; to_value = sb to_value;
direction; body }
| Static_raise (static_exn, args) ->
Static_raise (static_exn, List.map sb args)
| Static_catch _ | Try_with _ | While _
| Let _ | Let_rec _ | Proved_unreachable -> flam
in
let aux_named (named : Flambda.named) : Flambda.named =
match named with
| Symbol _ | Const _ | Expr _ -> named
| Allocated_const _ | Read_mutable _ -> named
| Read_symbol_field _ -> named
| Set_of_closures set_of_closures ->
let set_of_closures =
Flambda.create_set_of_closures
~function_decls:set_of_closures.function_decls
~free_vars:(Variable.Map.map sb set_of_closures.free_vars)
~specialised_args:
(Variable.Map.map sb set_of_closures.specialised_args)
in
Set_of_closures set_of_closures
| Project_closure project_closure ->
Project_closure {
project_closure with
set_of_closures = sb project_closure.set_of_closures;
}
| Move_within_set_of_closures move_within_set_of_closures ->
Move_within_set_of_closures {
move_within_set_of_closures with
closure = sb move_within_set_of_closures.closure;
}
| Project_var project_var ->
Project_var {
project_var with
closure = sb project_var.closure;
}
| Prim (prim, args, dbg) ->
Prim (prim, List.map sb args, dbg)
in
if Variable.Map.is_empty sb' then tree
else Flambda_iterators.map_toplevel aux aux_named tree
let make_closure_declaration ~id ~body ~params : Flambda.t =
let free_variables = Flambda.free_variables body in
let param_set = Variable.Set.of_list params in
if not (Variable.Set.subset param_set free_variables) then begin
Misc.fatal_error "Flambda_utils.make_closure_declaration"
end;
let sb =
Variable.Set.fold
(fun id sb -> Variable.Map.add id (Variable.rename id) sb)
free_variables Variable.Map.empty
in
(* CR-soon mshinwell: try to eliminate this [toplevel_substitution]. This
function is only called from [Inline_and_simplify], so we should be able
to do something similar to what happens in [Inlining_transforms] now. *)
let body = toplevel_substitution sb body in
let subst id = Variable.Map.find id sb in
let function_declaration =
Flambda.create_function_declaration ~params:(List.map subst params)
~body ~stub:false ~dbg:Debuginfo.none ~inline:Default_inline
~is_a_functor:false
in
assert (Variable.Set.equal (Variable.Set.map subst free_variables)
function_declaration.free_variables);
let free_vars =
Variable.Map.fold (fun id id' fv' ->
Variable.Map.add id' id fv')
(Variable.Map.filter (fun id _ -> not (Variable.Set.mem id param_set))
sb)
Variable.Map.empty
in
let compilation_unit = Compilation_unit.get_current_exn () in
let set_of_closures_var =
Variable.create "set_of_closures"
~current_compilation_unit:compilation_unit
in
let set_of_closures =
let function_decls =
Flambda.create_function_declarations
~set_of_closures_id:(Set_of_closures_id.create compilation_unit)
~funs:(Variable.Map.singleton id function_declaration)
in
Flambda.create_set_of_closures ~function_decls ~free_vars
~specialised_args:Variable.Map.empty
in
let project_closure : Flambda.named =
Project_closure {
set_of_closures = set_of_closures_var;
closure_id = Closure_id.wrap id;
}
in
let project_closure_var =
Variable.create "project_closure"
~current_compilation_unit:compilation_unit
in
Flambda.create_let set_of_closures_var (Set_of_closures set_of_closures)
(Flambda.create_let project_closure_var project_closure
(Var (project_closure_var)))
let bind ~bindings ~body =
List.fold_left (fun expr (var, var_def) ->
Flambda.create_let var var_def expr)
body bindings
let name_expr (named : Flambda.named) ~name : Flambda.t =
let var =
Variable.create
~current_compilation_unit:(Compilation_unit.get_current_exn ())
name
in
Flambda.create_let var named (Var var)
let all_lifted_constants (program : Flambda.program) =
let rec loop (program : Flambda.program_body) =
match program with
| Let_symbol (symbol, decl, program) -> (symbol, decl) :: (loop program)
| Let_rec_symbol (decls, program) ->
List.fold_left (fun l (symbol, decl) -> (symbol, decl) :: l)
(loop program)
decls
| Initialize_symbol (_, _, _, program)
| Effect (_, program) -> loop program
| End _ -> []
in
loop program.program_body
let all_lifted_constants_as_map program =
Symbol.Map.of_list (all_lifted_constants program)
let initialize_symbols (program : Flambda.program) =
let rec loop (program : Flambda.program_body) =
match program with
| Initialize_symbol (symbol, tag, fields, program) ->
(symbol, tag, fields) :: (loop program)
| Effect (_, program)
| Let_symbol (_, _, program)
| Let_rec_symbol (_, program) -> loop program
| End _ -> []
in
loop program.program_body
let imported_symbols (program : Flambda.program) =
program.imported_symbols
let needed_import_symbols (program : Flambda.program) =
let dependencies = Flambda.free_symbols_program program in
let defined_symbol =
Symbol.Set.union
(Symbol.Set.of_list
(List.map fst (all_lifted_constants program)))
(Symbol.Set.of_list
(List.map (fun (s, _, _) -> s) (initialize_symbols program)))
in
Symbol.Set.diff dependencies defined_symbol
let introduce_needed_import_symbols program : Flambda.program =
{ program with
imported_symbols = needed_import_symbols program;
}
let root_symbol (program : Flambda.program) =
let rec loop (program : Flambda.program_body) =
match program with
| Effect (_, program)
| Let_symbol (_, _, program)
| Let_rec_symbol (_, program)
| Initialize_symbol (_, _, _, program) -> loop program
| End root ->
root
in
loop program.program_body
let might_raise_static_exn flam stexn =
try
Flambda_iterators.iter_on_named
(function
| Flambda.Static_raise (ex, _) when Static_exception.equal ex stexn ->
raise Exit
| _ -> ())
(fun _ -> ())
flam;
false
with Exit -> true
let make_closure_map program =
let map = ref Closure_id.Map.empty in
let add_set_of_closures ~constant:_ : Flambda.set_of_closures -> unit = fun
{ function_decls } ->
Variable.Map.iter (fun var _ ->
let closure_id = Closure_id.wrap var in
map := Closure_id.Map.add closure_id function_decls !map)
function_decls.funs
in
Flambda_iterators.iter_on_set_of_closures_of_program
program
~f:add_set_of_closures;
!map
let make_closure_map' input =
let map = ref Closure_id.Map.empty in
let add_set_of_closures _ (function_decls : Flambda.function_declarations) =
Variable.Map.iter (fun var _ ->
let closure_id = Closure_id.wrap var in
map := Closure_id.Map.add closure_id function_decls !map)
function_decls.funs
in
Set_of_closures_id.Map.iter add_set_of_closures input;
!map
let all_lifted_constant_sets_of_closures program =
let set = ref Set_of_closures_id.Set.empty in
List.iter (function
| (_, Flambda.Set_of_closures {
function_decls = { set_of_closures_id } }) ->
set := Set_of_closures_id.Set.add set_of_closures_id !set
| _ -> ())
(all_lifted_constants program);
!set
let all_sets_of_closures program =
let list = ref [] in
Flambda_iterators.iter_on_set_of_closures_of_program program
~f:(fun ~constant:_ set_of_closures ->
list := set_of_closures :: !list);
!list
let all_sets_of_closures_map program =
let r = ref Set_of_closures_id.Map.empty in
Flambda_iterators.iter_on_set_of_closures_of_program program
~f:(fun ~constant:_ set_of_closures ->
r := Set_of_closures_id.Map.add
set_of_closures.function_decls.set_of_closures_id
set_of_closures !r);
!r
let all_function_decls_indexed_by_set_of_closures_id program =
Set_of_closures_id.Map.map
(fun { Flambda. function_decls; _ } -> function_decls)
(all_sets_of_closures_map program)
let all_function_decls_indexed_by_closure_id program =
let aux_fun function_decls fun_var _ map =
let closure_id = Closure_id.wrap fun_var in
Closure_id.Map.add closure_id function_decls map
in
let aux _ ({ function_decls; _ } : Flambda.set_of_closures) map =
Variable.Map.fold (aux_fun function_decls) function_decls.funs map
in
Set_of_closures_id.Map.fold aux (all_sets_of_closures_map program)
Closure_id.Map.empty
let make_variable_symbol var =
Symbol.create (Compilation_unit.get_current_exn ())
(Linkage_name.create
(Variable.unique_name (Variable.rename var)))
let make_variables_symbol vars =
let name =
String.concat "_and_"
(List.map (fun var -> Variable.unique_name (Variable.rename var)) vars)
in
Symbol.create (Compilation_unit.get_current_exn ()) (Linkage_name.create name)
let substitute_read_symbol_field_for_variables
(substitution : (Symbol.t * int list) Variable.Map.t)
(expr : Flambda.t) =
let bind var fresh_var (expr:Flambda.t) : Flambda.t =
let symbol, path = Variable.Map.find var substitution in
let rec make_named (path:int list) : Flambda.named =
match path with
| [] -> Symbol symbol
| [i] -> Read_symbol_field (symbol, i)
| h :: t ->
let block = Variable.create "symbol_field_block" in
let field = Variable.create "get_symbol_field" in
Expr (
Flambda.create_let block (make_named t)
(Flambda.create_let field
(Prim (Pfield h, [block], Debuginfo.none))
(Var field)))
in
Flambda.create_let fresh_var (make_named path) expr
in
let substitute_named bindings (named:Flambda.named) : Flambda.named =
let sb to_substitute =
try Variable.Map.find to_substitute bindings with
| Not_found ->
to_substitute
in
match named with
| Symbol _ | Const _ | Expr _ -> named
| Allocated_const _ | Read_mutable _ -> named
| Read_symbol_field _ -> named
| Set_of_closures set_of_closures ->
let set_of_closures =
Flambda.create_set_of_closures
~function_decls:set_of_closures.function_decls
~free_vars:(Variable.Map.map sb set_of_closures.free_vars)
~specialised_args:
(Variable.Map.map sb set_of_closures.specialised_args)
in
Set_of_closures set_of_closures
| Project_closure project_closure ->
Project_closure {
project_closure with
set_of_closures = sb project_closure.set_of_closures;
}
| Move_within_set_of_closures move_within_set_of_closures ->
Move_within_set_of_closures {
move_within_set_of_closures with
closure = sb move_within_set_of_closures.closure;
}
| Project_var project_var ->
Project_var {
project_var with
closure = sb project_var.closure;
}
| Prim (prim, args, dbg) ->
Prim (prim, List.map sb args, dbg)
in
let make_var_subst var =
if Variable.Map.mem var substitution then
let fresh = Variable.rename var in
fresh, (fun expr -> bind var fresh expr)
else
var, (fun x -> x)
in
let f (expr:Flambda.t) : Flambda.t =
match expr with
| Var v when Variable.Map.mem v substitution ->
let fresh = Variable.rename v in
bind v fresh (Var fresh)
| Var _ -> expr
| Let ({ var = v; defining_expr = named; _ } as let_expr) ->
let to_substitute =
Variable.Set.filter
(fun v -> Variable.Map.mem v substitution)
(Flambda.free_variables_named named)
in
if Variable.Set.is_empty to_substitute then
expr
else
let bindings =
Variable.Map.of_set (fun var -> Variable.rename var) to_substitute
in
let named =
substitute_named bindings named
in
let expr =
let module W = Flambda.With_free_variables in
W.create_let_reusing_body v named (W.of_body_of_let let_expr)
in
Variable.Map.fold (fun to_substitute fresh expr ->
bind to_substitute fresh expr)
bindings expr
| Let_mutable (mut_var, var, body) when Variable.Map.mem var substitution ->
let fresh = Variable.rename var in
bind var fresh (Let_mutable (mut_var, fresh, body))
| Let_mutable (_mut_var, _var, _body) ->
expr
| Let_rec (defs, body) ->
let free_variables_of_defs =
List.fold_left (fun set (_, named) ->
Variable.Set.union set (Flambda.free_variables_named named))
Variable.Set.empty defs
in
let to_substitute =
Variable.Set.filter
(fun v -> Variable.Map.mem v substitution)
free_variables_of_defs
in
if Variable.Set.is_empty to_substitute then
expr
else begin
let bindings =
Variable.Map.of_set (fun var -> Variable.rename var) to_substitute
in
let defs =
List.map (fun (var, named) ->
var, substitute_named bindings named)
defs
in
let expr =
Flambda.Let_rec (defs, body)
in
Variable.Map.fold (fun to_substitute fresh expr ->
bind to_substitute fresh expr)
bindings expr
end
| If_then_else (cond, ifso, ifnot) when Variable.Map.mem cond substitution ->
let fresh = Variable.rename cond in
bind cond fresh (If_then_else (fresh, ifso, ifnot))
| If_then_else _ ->
expr
| Switch (cond, sw) when Variable.Map.mem cond substitution ->
let fresh = Variable.rename cond in
bind cond fresh (Switch (fresh, sw))
| Switch _ ->
expr
| String_switch (cond, sw, def) when Variable.Map.mem cond substitution ->
let fresh = Variable.rename cond in
bind cond fresh (String_switch (fresh, sw, def))
| String_switch _ ->
expr
| Assign { being_assigned; new_value } when Variable.Map.mem new_value substitution ->
let fresh = Variable.rename new_value in
bind new_value fresh (Assign { being_assigned; new_value = fresh })
| Assign _ ->
expr
| Static_raise (exn, args) ->
let args, bind_args =
List.split (List.map make_var_subst args)
in
List.fold_right (fun f expr -> f expr) bind_args @@
Flambda.Static_raise (exn, args)
| For { bound_var; from_value; to_value; direction; body } ->
let from_value, bind_from_value = make_var_subst from_value in
let to_value, bind_to_value = make_var_subst to_value in
bind_from_value @@
bind_to_value @@
Flambda.For { bound_var; from_value; to_value; direction; body }
| Apply { func; args; kind; dbg; inline } ->
let func, bind_func = make_var_subst func in
let args, bind_args =
List.split (List.map make_var_subst args)
in
bind_func @@
List.fold_right (fun f expr -> f expr) bind_args @@
Flambda.Apply { func; args; kind; dbg; inline }
| Send { kind; meth; obj; args; dbg } ->
let meth, bind_meth = make_var_subst meth in
let obj, bind_obj = make_var_subst obj in
let args, bind_args =
List.split (List.map make_var_subst args)
in
bind_meth @@
bind_obj @@
List.fold_right (fun f expr -> f expr) bind_args @@
Flambda.Send { kind; meth; obj; args; dbg }
| Proved_unreachable
| While _
| Try_with _
| Static_catch _ ->
(* No variables directly used in those expressions *)
expr
in
Flambda_iterators.map_toplevel f (fun v -> v) expr
(* CR-soon mshinwell: implement this so that sharing can occur in
matches. Should probably leave this for the first release. *)
type sharing_key = unit
let make_key _ = None
module Switch_storer =
Switch.Store
(struct
type t = Flambda.t
type key = sharing_key
let make_key = make_key
end)
let fun_vars_referenced_in_decls
(function_decls : Flambda.function_declarations) ~backend =
let fun_vars = Variable.Map.keys function_decls.funs in
let symbols_to_fun_vars =
let module Backend = (val backend : Backend_intf.S) in
Variable.Set.fold (fun fun_var symbols_to_fun_vars ->
let closure_id = Closure_id.wrap fun_var in
let symbol = Backend.closure_symbol closure_id in
Symbol.Map.add symbol fun_var symbols_to_fun_vars)
fun_vars
Symbol.Map.empty
in
Variable.Map.map (fun (func_decl : Flambda.function_declaration) ->
let from_symbols =
Symbol.Set.fold (fun symbol fun_vars' ->
match Symbol.Map.find symbol symbols_to_fun_vars with
| exception Not_found -> fun_vars'
| fun_var ->
assert (Variable.Set.mem fun_var fun_vars);
Variable.Set.add fun_var fun_vars')
func_decl.free_symbols
Variable.Set.empty
in
let from_variables =
Variable.Set.inter func_decl.free_variables fun_vars
in
Variable.Set.union from_symbols from_variables)
function_decls.funs
let closures_required_by_entry_point ~(entry_point : Closure_id.t) ~backend
(function_decls : Flambda.function_declarations) =
let dependencies =
fun_vars_referenced_in_decls function_decls ~backend
in
let set = ref Variable.Set.empty in
let queue = Queue.create () in
let add v =
if not (Variable.Set.mem v !set) then begin
set := Variable.Set.add v !set;
Queue.push v queue
end
in
add (Closure_id.unwrap entry_point);
while not (Queue.is_empty queue) do
let fun_var = Queue.pop queue in
match Variable.Map.find fun_var dependencies with
| exception Not_found -> ()
| fun_dependencies ->
Variable.Set.iter (fun dep ->
if Variable.Map.mem dep function_decls.funs then
add dep)
fun_dependencies
done;
!set
let all_functions_parameters (function_decls : Flambda.function_declarations) =
Variable.Map.fold (fun _ ({ params } : Flambda.function_declaration) set ->
Variable.Set.union set (Variable.Set.of_list params))
function_decls.funs Variable.Set.empty
let all_free_symbols (function_decls : Flambda.function_declarations) =
Variable.Map.fold (fun _ (function_decl : Flambda.function_declaration) syms ->
Symbol.Set.union syms function_decl.free_symbols)
function_decls.funs Symbol.Set.empty

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