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

Improve location handling in the middle end (version for merging) (#666)

master
Mark Shinwell 2016-07-06 15:42:29 +01:00 committed by GitHub
parent a22432b15f
commit 5f00ce793e
72 changed files with 1114 additions and 911 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
.depend
View File

@ -526,11 +526,11 @@ bytecomp/bytesections.cmo : utils/config.cmi bytecomp/bytesections.cmi
bytecomp/bytesections.cmx : utils/config.cmx bytecomp/bytesections.cmi
bytecomp/bytesections.cmi :
bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi
bytecomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \
bytecomp/debuginfo.cmi
bytecomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \
bytecomp/debuginfo.cmi
bytecomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi
middle_end/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \
middle_end/debuginfo.cmi
middle_end/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \
middle_end/debuginfo.cmi
middle_end/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi
bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi
bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi
bytecomp/dll.cmi :
@ -804,21 +804,21 @@ asmcomp/build_export_info.cmx : middle_end/base_types/variable.cmx \
asmcomp/build_export_info.cmi : middle_end/flambda.cmi \
asmcomp/export_info.cmi middle_end/backend_intf.cmi
asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \
bytecomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
middle_end/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \
bytecomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
middle_end/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \
bytecomp/debuginfo.cmi parsing/asttypes.cmi
middle_end/debuginfo.cmi parsing/asttypes.cmi
asmcomp/closure.cmo : utils/warnings.cmi utils/tbl.cmi bytecomp/switch.cmi \
bytecomp/simplif.cmi typing/primitive.cmi utils/misc.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
bytecomp/debuginfo.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
middle_end/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 typing/env.cmx \
bytecomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
middle_end/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
asmcomp/closure.cmi
asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
@ -835,22 +835,22 @@ asmcomp/closure_offsets.cmx : middle_end/base_types/variable.cmx \
asmcomp/closure_offsets.cmi : middle_end/base_types/var_within_closure.cmi \
middle_end/flambda.cmi middle_end/base_types/closure_id.cmi
asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \
bytecomp/debuginfo.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
middle_end/debuginfo.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \
bytecomp/debuginfo.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
middle_end/debuginfo.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi \
bytecomp/debuginfo.cmi
middle_end/debuginfo.cmi
asmcomp/cmmgen.cmo : asmcomp/un_anf.cmi typing/types.cmi bytecomp/switch.cmi \
asmcomp/strmatch.cmi asmcomp/proc.cmi bytecomp/printlambda.cmi \
typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
bytecomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \
asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
asmcomp/cmmgen.cmi
asmcomp/cmmgen.cmx : asmcomp/un_anf.cmx typing/types.cmx bytecomp/switch.cmx \
asmcomp/strmatch.cmx asmcomp/proc.cmx bytecomp/printlambda.cmx \
typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \
bytecomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \
asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
asmcomp/cmmgen.cmi
@ -896,22 +896,22 @@ asmcomp/emit.cmo : asmcomp/x86_proc.cmi asmcomp/x86_masm.cmi \
asmcomp/x86_gas.cmi asmcomp/x86_dsl.cmi asmcomp/x86_ast.cmi \
asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/emitaux.cmi \
bytecomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
asmcomp/cmm.cmi utils/clflags.cmi asmcomp/branch_relaxation.cmi \
asmcomp/arch.cmo asmcomp/emit.cmi
asmcomp/emit.cmx : asmcomp/x86_proc.cmx asmcomp/x86_masm.cmx \
asmcomp/x86_gas.cmx asmcomp/x86_dsl.cmx asmcomp/x86_ast.cmi \
asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/emitaux.cmx \
bytecomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/branch_relaxation.cmx \
asmcomp/arch.cmx asmcomp/emit.cmi
asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
asmcomp/emitaux.cmo : asmcomp/linearize.cmi bytecomp/debuginfo.cmi \
asmcomp/emitaux.cmo : asmcomp/linearize.cmi middle_end/debuginfo.cmi \
utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
asmcomp/emitaux.cmx : asmcomp/linearize.cmx bytecomp/debuginfo.cmx \
asmcomp/emitaux.cmx : asmcomp/linearize.cmx middle_end/debuginfo.cmx \
utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/emitaux.cmi : bytecomp/debuginfo.cmi
asmcomp/emitaux.cmi : middle_end/debuginfo.cmi
asmcomp/export_info.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi \
middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
@ -964,7 +964,7 @@ asmcomp/flambda_to_clambda.cmo : middle_end/base_types/variable.cmi \
utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
utils/misc.cmi middle_end/base_types/linkage_name.cmi typing/ident.cmi \
middle_end/flambda_utils.cmi middle_end/flambda.cmi \
asmcomp/export_info.cmi bytecomp/debuginfo.cmi asmcomp/compilenv.cmi \
asmcomp/export_info.cmi middle_end/debuginfo.cmi asmcomp/compilenv.cmi \
asmcomp/closure_offsets.cmi middle_end/base_types/closure_id.cmi \
utils/clflags.cmi asmcomp/clambda.cmi middle_end/allocated_const.cmi \
asmcomp/flambda_to_clambda.cmi
@ -976,7 +976,7 @@ asmcomp/flambda_to_clambda.cmx : middle_end/base_types/variable.cmx \
utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \
utils/misc.cmx middle_end/base_types/linkage_name.cmx typing/ident.cmx \
middle_end/flambda_utils.cmx middle_end/flambda.cmx \
asmcomp/export_info.cmx bytecomp/debuginfo.cmx asmcomp/compilenv.cmx \
asmcomp/export_info.cmx middle_end/debuginfo.cmx asmcomp/compilenv.cmx \
asmcomp/closure_offsets.cmx middle_end/base_types/closure_id.cmx \
utils/clflags.cmx asmcomp/clambda.cmx middle_end/allocated_const.cmx \
asmcomp/flambda_to_clambda.cmi
@ -1006,13 +1006,13 @@ asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
asmcomp/interf.cmi
asmcomp/interf.cmi : asmcomp/mach.cmi
asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi bytecomp/lambda.cmi bytecomp/debuginfo.cmi \
asmcomp/mach.cmi bytecomp/lambda.cmi middle_end/debuginfo.cmi \
asmcomp/cmm.cmi asmcomp/linearize.cmi
asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
asmcomp/mach.cmx bytecomp/lambda.cmx bytecomp/debuginfo.cmx \
asmcomp/mach.cmx bytecomp/lambda.cmx middle_end/debuginfo.cmx \
asmcomp/cmm.cmx asmcomp/linearize.cmi
asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \
bytecomp/debuginfo.cmi
middle_end/debuginfo.cmi
asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/liveness.cmi
@ -1021,11 +1021,11 @@ asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
asmcomp/liveness.cmi
asmcomp/liveness.cmi : asmcomp/mach.cmi
asmcomp/mach.cmo : asmcomp/reg.cmi bytecomp/lambda.cmi \
bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/mach.cmi
middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/mach.cmi
asmcomp/mach.cmx : asmcomp/reg.cmx bytecomp/lambda.cmx \
bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/mach.cmi
middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/mach.cmi
asmcomp/mach.cmi : asmcomp/reg.cmi bytecomp/lambda.cmi \
bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \
typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \
asmcomp/printclambda.cmi
@ -1034,24 +1034,24 @@ asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \
asmcomp/printclambda.cmi
asmcomp/printclambda.cmi : asmcomp/clambda.cmi
asmcomp/printcmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \
bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi
middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi
asmcomp/printcmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \
bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi
middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi
asmcomp/printcmm.cmi : asmcomp/cmm.cmi
asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi bytecomp/lambda.cmi bytecomp/debuginfo.cmi \
asmcomp/linearize.cmi bytecomp/lambda.cmi middle_end/debuginfo.cmi \
asmcomp/printlinear.cmi
asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/mach.cmx \
asmcomp/linearize.cmx bytecomp/lambda.cmx bytecomp/debuginfo.cmx \
asmcomp/linearize.cmx bytecomp/lambda.cmx middle_end/debuginfo.cmx \
asmcomp/printlinear.cmi
asmcomp/printlinear.cmi : asmcomp/linearize.cmi
asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
asmcomp/printcmm.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \
bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/printmach.cmi
asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
asmcomp/printcmm.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \
bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
asmcomp/printmach.cmi
asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/proc.cmo : asmcomp/x86_proc.cmi asmcomp/reg.cmi utils/misc.cmi \
@ -1086,14 +1086,14 @@ asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.cmi
asmcomp/scheduling.cmi : asmcomp/linearize.cmi
asmcomp/selectgen.cmo : utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \
asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \
typing/ident.cmi bytecomp/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.cmi \
typing/ident.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.cmi \
asmcomp/arch.cmo asmcomp/selectgen.cmi
asmcomp/selectgen.cmx : utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \
asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \
typing/ident.cmx bytecomp/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \
typing/ident.cmx middle_end/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \
asmcomp/arch.cmx asmcomp/selectgen.cmi
asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
typing/ident.cmi bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
typing/ident.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \
asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \
asmcomp/selection.cmi
@ -1118,11 +1118,11 @@ asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/cmm.cmx \
asmcomp/strmatch.cmi : asmcomp/cmm.cmi
asmcomp/un_anf.cmo : middle_end/semantics_of_primitives.cmi \
asmcomp/printclambda.cmi utils/misc.cmi bytecomp/lambda.cmi \
typing/ident.cmi bytecomp/debuginfo.cmi utils/clflags.cmi \
typing/ident.cmi middle_end/debuginfo.cmi utils/clflags.cmi \
asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/un_anf.cmi
asmcomp/un_anf.cmx : middle_end/semantics_of_primitives.cmx \
asmcomp/printclambda.cmx utils/misc.cmx bytecomp/lambda.cmx \
typing/ident.cmx bytecomp/debuginfo.cmx utils/clflags.cmx \
typing/ident.cmx middle_end/debuginfo.cmx utils/clflags.cmx \
asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/un_anf.cmi
asmcomp/un_anf.cmi : asmcomp/clambda.cmi
asmcomp/x86_ast.cmi :
@ -1170,7 +1170,7 @@ middle_end/augment_specialised_args.cmo : middle_end/base_types/variable.cmi \
middle_end/pass_wrapper.cmi utils/misc.cmi middle_end/inlining_cost.cmi \
middle_end/inline_and_simplify_aux.cmi utils/identifiable.cmi \
middle_end/flambda_utils.cmi middle_end/flambda.cmi \
bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi \
middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi \
utils/clflags.cmi middle_end/backend_intf.cmi \
middle_end/augment_specialised_args.cmi
middle_end/augment_specialised_args.cmx : middle_end/base_types/variable.cmx \
@ -1178,7 +1178,7 @@ middle_end/augment_specialised_args.cmx : middle_end/base_types/variable.cmx \
middle_end/pass_wrapper.cmx utils/misc.cmx middle_end/inlining_cost.cmx \
middle_end/inline_and_simplify_aux.cmx utils/identifiable.cmx \
middle_end/flambda_utils.cmx middle_end/flambda.cmx \
bytecomp/debuginfo.cmx middle_end/base_types/closure_id.cmx \
middle_end/debuginfo.cmx middle_end/base_types/closure_id.cmx \
utils/clflags.cmx middle_end/backend_intf.cmi \
middle_end/augment_specialised_args.cmi
middle_end/augment_specialised_args.cmi : middle_end/base_types/variable.cmi \
@ -1195,7 +1195,7 @@ middle_end/closure_conversion.cmo : middle_end/base_types/variable.cmi \
utils/misc.cmi parsing/location.cmi \
middle_end/base_types/linkage_name.cmi middle_end/lift_code.cmi \
bytecomp/lambda.cmi typing/ident.cmi middle_end/flambda_utils.cmi \
middle_end/flambda.cmi bytecomp/debuginfo.cmi \
middle_end/flambda.cmi middle_end/debuginfo.cmi \
middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/closure_id.cmi \
middle_end/closure_conversion_aux.cmi utils/clflags.cmi \
@ -1209,7 +1209,7 @@ middle_end/closure_conversion.cmx : middle_end/base_types/variable.cmx \
utils/misc.cmx parsing/location.cmx \
middle_end/base_types/linkage_name.cmx middle_end/lift_code.cmx \
bytecomp/lambda.cmx typing/ident.cmx middle_end/flambda_utils.cmx \
middle_end/flambda.cmx bytecomp/debuginfo.cmx \
middle_end/flambda.cmx middle_end/debuginfo.cmx \
middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/closure_id.cmx \
middle_end/closure_conversion_aux.cmx utils/clflags.cmx \
@ -1271,7 +1271,7 @@ middle_end/flambda.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
bytecomp/printlambda.cmi utils/numbers.cmi \
middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
bytecomp/lambda.cmi utils/identifiable.cmi bytecomp/debuginfo.cmi \
bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \
middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/closure_id.cmi utils/clflags.cmi \
parsing/asttypes.cmi middle_end/allocated_const.cmi \
@ -1283,7 +1283,7 @@ middle_end/flambda.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \
bytecomp/printlambda.cmx utils/numbers.cmx \
middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
bytecomp/lambda.cmx utils/identifiable.cmx bytecomp/debuginfo.cmx \
bytecomp/lambda.cmx utils/identifiable.cmx middle_end/debuginfo.cmx \
middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/closure_id.cmx utils/clflags.cmx \
parsing/asttypes.cmi middle_end/allocated_const.cmx \
@ -1294,7 +1294,7 @@ middle_end/flambda.cmi : middle_end/base_types/variable.cmi \
middle_end/base_types/set_of_closures_origin.cmi \
middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
bytecomp/lambda.cmi utils/identifiable.cmi bytecomp/debuginfo.cmi \
bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \
middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \
middle_end/allocated_const.cmi
middle_end/flambda_invariants.cmo : middle_end/base_types/variable.cmi \
@ -1306,7 +1306,7 @@ middle_end/flambda_invariants.cmo : middle_end/base_types/variable.cmi \
bytecomp/printlambda.cmi utils/numbers.cmi \
middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
bytecomp/lambda.cmi typing/ident.cmi middle_end/flambda_iterators.cmi \
middle_end/flambda.cmi bytecomp/debuginfo.cmi \
middle_end/flambda.cmi middle_end/debuginfo.cmi \
middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \
middle_end/allocated_const.cmi middle_end/flambda_invariants.cmi
@ -1319,7 +1319,7 @@ middle_end/flambda_invariants.cmx : middle_end/base_types/variable.cmx \
bytecomp/printlambda.cmx utils/numbers.cmx \
middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
bytecomp/lambda.cmx typing/ident.cmx middle_end/flambda_iterators.cmx \
middle_end/flambda.cmx bytecomp/debuginfo.cmx \
middle_end/flambda.cmx middle_end/debuginfo.cmx \
middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/closure_id.cmx parsing/asttypes.cmi \
middle_end/allocated_const.cmx middle_end/flambda_invariants.cmi
@ -1337,7 +1337,7 @@ middle_end/flambda_utils.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
middle_end/base_types/linkage_name.cmi middle_end/flambda_iterators.cmi \
middle_end/flambda.cmi bytecomp/debuginfo.cmi \
middle_end/flambda.cmi middle_end/debuginfo.cmi \
middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \
middle_end/allocated_const.cmi middle_end/flambda_utils.cmi
@ -1348,7 +1348,7 @@ middle_end/flambda_utils.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \
middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
middle_end/base_types/linkage_name.cmx middle_end/flambda_iterators.cmx \
middle_end/flambda.cmx bytecomp/debuginfo.cmx \
middle_end/flambda.cmx middle_end/debuginfo.cmx \
middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
middle_end/allocated_const.cmx middle_end/flambda_utils.cmi
@ -1424,7 +1424,7 @@ middle_end/inline_and_simplify.cmo : utils/warnings.cmi \
middle_end/inline_and_simplify_aux.cmi typing/ident.cmi \
middle_end/freshening.cmi middle_end/flambda_utils.cmi \
middle_end/flambda.cmi middle_end/effect_analysis.cmi \
bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi \
middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi \
utils/clflags.cmi middle_end/backend_intf.cmi \
middle_end/allocated_const.cmi middle_end/inline_and_simplify.cmi
middle_end/inline_and_simplify.cmx : utils/warnings.cmx \
@ -1444,7 +1444,7 @@ middle_end/inline_and_simplify.cmx : utils/warnings.cmx \
middle_end/inline_and_simplify_aux.cmx typing/ident.cmx \
middle_end/freshening.cmx middle_end/flambda_utils.cmx \
middle_end/flambda.cmx middle_end/effect_analysis.cmx \
bytecomp/debuginfo.cmx middle_end/base_types/closure_id.cmx \
middle_end/debuginfo.cmx middle_end/base_types/closure_id.cmx \
utils/clflags.cmx middle_end/backend_intf.cmi \
middle_end/allocated_const.cmx middle_end/inline_and_simplify.cmi
middle_end/inline_and_simplify.cmi : middle_end/base_types/variable.cmi \
@ -1483,7 +1483,7 @@ middle_end/inline_and_simplify_aux.cmi : middle_end/base_types/variable.cmi \
middle_end/base_types/set_of_closures_origin.cmi \
middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \
middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \
middle_end/freshening.cmi middle_end/flambda.cmi bytecomp/debuginfo.cmi \
middle_end/freshening.cmi middle_end/flambda.cmi middle_end/debuginfo.cmi \
middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi
middle_end/inlining_cost.cmo : middle_end/base_types/variable.cmi \
middle_end/projection.cmi typing/primitive.cmi utils/misc.cmi \
@ -1517,21 +1517,21 @@ middle_end/inlining_decision.cmi : middle_end/base_types/variable.cmi \
middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
middle_end/inlining_decision_intf.cmi \
middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi
middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi
middle_end/inlining_decision_intf.cmi : middle_end/base_types/variable.cmi \
middle_end/simple_value_approx.cmi middle_end/inline_and_simplify_aux.cmi \
middle_end/flambda.cmi bytecomp/debuginfo.cmi \
middle_end/flambda.cmi middle_end/debuginfo.cmi \
middle_end/base_types/closure_id.cmi
middle_end/inlining_stats.cmo : utils/misc.cmi \
middle_end/inlining_stats_types.cmi bytecomp/debuginfo.cmi \
middle_end/inlining_stats_types.cmi middle_end/debuginfo.cmi \
middle_end/base_types/closure_id.cmi utils/clflags.cmi \
middle_end/inlining_stats.cmi
middle_end/inlining_stats.cmx : utils/misc.cmx \
middle_end/inlining_stats_types.cmx bytecomp/debuginfo.cmx \
middle_end/inlining_stats_types.cmx middle_end/debuginfo.cmx \
middle_end/base_types/closure_id.cmx utils/clflags.cmx \
middle_end/inlining_stats.cmi
middle_end/inlining_stats.cmi : middle_end/inlining_stats_types.cmi \
bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi
middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi
middle_end/inlining_stats_types.cmo : middle_end/inlining_cost.cmi \
middle_end/inlining_stats_types.cmi
middle_end/inlining_stats_types.cmx : middle_end/inlining_cost.cmx \
@ -1555,7 +1555,7 @@ middle_end/inlining_transforms.cmi : middle_end/base_types/variable.cmi \
middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
middle_end/inlining_decision_intf.cmi \
middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi
middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi
middle_end/invariant_params.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \
middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
@ -1607,12 +1607,12 @@ middle_end/lift_constants.cmi : middle_end/flambda.cmi \
middle_end/lift_let_to_initialize_symbol.cmo : \
middle_end/base_types/variable.cmi middle_end/base_types/tag.cmi \
middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \
middle_end/flambda.cmi bytecomp/debuginfo.cmi parsing/asttypes.cmi \
middle_end/flambda.cmi middle_end/debuginfo.cmi parsing/asttypes.cmi \
middle_end/lift_let_to_initialize_symbol.cmi
middle_end/lift_let_to_initialize_symbol.cmx : \
middle_end/base_types/variable.cmx middle_end/base_types/tag.cmx \
middle_end/base_types/symbol.cmx middle_end/flambda_utils.cmx \
middle_end/flambda.cmx bytecomp/debuginfo.cmx parsing/asttypes.cmi \
middle_end/flambda.cmx middle_end/debuginfo.cmx parsing/asttypes.cmi \
middle_end/lift_let_to_initialize_symbol.cmi
middle_end/lift_let_to_initialize_symbol.cmi : middle_end/flambda.cmi \
middle_end/backend_intf.cmi
@ -1627,7 +1627,7 @@ middle_end/middle_end.cmo : utils/warnings.cmi \
middle_end/inlining_cost.cmi middle_end/inline_and_simplify.cmi \
middle_end/initialize_symbol_to_let_symbol.cmi \
middle_end/flambda_iterators.cmi middle_end/flambda_invariants.cmi \
middle_end/flambda.cmi bytecomp/debuginfo.cmi \
middle_end/flambda.cmi middle_end/debuginfo.cmi \
middle_end/base_types/closure_id.cmi middle_end/closure_conversion.cmi \
utils/clflags.cmi middle_end/backend_intf.cmi middle_end/middle_end.cmi
middle_end/middle_end.cmx : utils/warnings.cmx \
@ -1641,7 +1641,7 @@ middle_end/middle_end.cmx : utils/warnings.cmx \
middle_end/inlining_cost.cmx middle_end/inline_and_simplify.cmx \
middle_end/initialize_symbol_to_let_symbol.cmx \
middle_end/flambda_iterators.cmx middle_end/flambda_invariants.cmx \
middle_end/flambda.cmx bytecomp/debuginfo.cmx \
middle_end/flambda.cmx middle_end/debuginfo.cmx \
middle_end/base_types/closure_id.cmx middle_end/closure_conversion.cmx \
utils/clflags.cmx middle_end/backend_intf.cmi middle_end/middle_end.cmi
middle_end/middle_end.cmi : utils/timings.cmi bytecomp/lambda.cmi \
@ -1787,7 +1787,7 @@ middle_end/simplify_primitives.cmx : middle_end/base_types/tag.cmx \
middle_end/simplify_primitives.cmi : middle_end/base_types/variable.cmi \
middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
middle_end/inlining_cost.cmi middle_end/flambda.cmi \
bytecomp/debuginfo.cmi
middle_end/debuginfo.cmi
middle_end/unbox_closures.cmo : middle_end/base_types/variable.cmi \
middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \

2
Makefile.shared
View File

@ -78,7 +78,6 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
bytecomp/translcore.cmo \
bytecomp/translclass.cmo bytecomp/translmod.cmo \
bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
bytecomp/debuginfo.cmo \
driver/pparse.cmo driver/main_args.cmo \
driver/compenv.cmo driver/compmisc.cmo
@ -137,6 +136,7 @@ ASMCOMP=\
driver/opterrors.cmo driver/optcompile.cmo
MIDDLE_END=\
middle_end/debuginfo.cmo \
middle_end/base_types/tag.cmo \
middle_end/base_types/linkage_name.cmo \
middle_end/base_types/compilation_unit.cmo \

24
asmcomp/amd64/emit.mlp
View File

@ -243,7 +243,7 @@ let addressing addr typ i n =
(* Record live pointers at call points -- see Emitaux *)
let record_frame_label ?label live dbg =
let record_frame_label ?label live raise_ dbg =
let lbl =
match label with
| None -> new_label()
@ -265,11 +265,12 @@ let record_frame_label ?label live dbg =
{ fd_lbl = lbl;
fd_frame_size = frame_size();
fd_live_offset = !live_offset;
fd_raise = raise_;
fd_debuginfo = dbg } :: !frame_descriptors;
lbl
let record_frame ?label live dbg =
let lbl = record_frame_label ?label live dbg in
let record_frame ?label live raise_ dbg =
let lbl = record_frame_label ?label live raise_ dbg in
def_label lbl
(* Record calls to the GC -- we've moved them out of the way *)
@ -301,7 +302,7 @@ let bound_error_call = ref 0
let bound_error_label ?label dbg =
if !Clflags.debug then begin
let lbl_bound_error = new_label() in
let lbl_frame = record_frame_label ?label Reg.Set.empty dbg in
let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
bound_error_sites :=
{ bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
lbl_bound_error
@ -488,11 +489,11 @@ let emit_instr fallthrough i =
load_symbol_addr s (res i 0)
| Lop(Icall_ind { label_after; }) ->
I.call (arg i 0);
record_frame i.live i.dbg ~label:label_after
record_frame i.live false i.dbg ~label:label_after
| Lop(Icall_imm { func; label_after; }) ->
add_used_symbol func;
emit_call func;
record_frame i.live i.dbg ~label:label_after
record_frame i.live false i.dbg ~label:label_after
| Lop(Itailcall_ind { label_after = _; }) ->
output_epilogue begin fun () ->
I.jmp (arg i 0)
@ -511,7 +512,7 @@ let emit_instr fallthrough i =
if alloc then begin
load_symbol_addr func rax;
emit_call "caml_c_call";
record_frame i.live i.dbg ~label:label_after;
record_frame i.live false i.dbg ~label:label_after;
if system <> S_win64 then begin
(* TODO: investigate why such a diff.
This comes from:
@ -582,7 +583,7 @@ let emit_instr fallthrough i =
end else
I.cmp (mem64_rip QWORD (emit_symbol "caml_young_limit")) r15;
let lbl_call_gc = new_label() in
let lbl_frame = record_frame_label i.live Debuginfo.none in
let lbl_frame = record_frame_label i.live false Debuginfo.none in
I.jb (label lbl_call_gc);
I.lea (mem64 NONE 8 R15) (res i 0);
call_gc_sites :=
@ -599,7 +600,8 @@ let emit_instr fallthrough i =
emit_call "caml_allocN"
end;
let label =
record_frame_label ?label:label_after_call_gc i.live Debuginfo.none
record_frame_label ?label:label_after_call_gc i.live false
Debuginfo.none
in
def_label label;
I.lea (mem64 NONE 8 R15) (res i 0)
@ -776,10 +778,10 @@ let emit_instr fallthrough i =
begin match !Clflags.debug, k with
| true, Lambda.Raise_regular ->
emit_call "caml_raise_exn";
record_frame Reg.Set.empty i.dbg
record_frame Reg.Set.empty true i.dbg
| true, Lambda.Raise_reraise ->
emit_call "caml_reraise_exn";
record_frame Reg.Set.empty i.dbg
record_frame Reg.Set.empty true i.dbg
| false, _
| true, Lambda.Raise_notrace ->
I.mov r14 rsp;

21
asmcomp/arm/emit.mlp
View File

@ -102,7 +102,7 @@ let emit_addressing addr r n =
(* Record live pointers at call points *)
let record_frame_label ?label live dbg =
let record_frame_label ?label live raise_ dbg =
let lbl =
match label with
| None -> new_label()
@ -123,11 +123,12 @@ let record_frame_label ?label live dbg =
{ fd_lbl = lbl;
fd_frame_size = frame_size();
fd_live_offset = !live_offset;
fd_raise = raise_;
fd_debuginfo = dbg } :: !frame_descriptors;
lbl
let record_frame ?label live dbg =
let lbl = record_frame_label ?label live dbg in `{emit_label lbl}:`
let record_frame ?label live raise_ dbg =
let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`
(* Record calls to the GC -- we've moved them out of the way *)
@ -155,7 +156,7 @@ let bound_error_sites = ref ([] : bound_error_call list)
let bound_error_label ?label dbg =
if !Clflags.debug || !bound_error_sites = [] then begin
let lbl_bound_error = new_label() in
let lbl_frame = record_frame_label ?label Reg.Set.empty dbg in
let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
bound_error_sites :=
{ bd_lbl = lbl_bound_error;
bd_frame_lbl = lbl_frame } :: !bound_error_sites;
@ -445,15 +446,15 @@ let emit_instr i =
| Lop(Icall_ind { label_after; }) ->
if !arch >= ARMv5 then begin
` blx {emit_reg i.arg.(0)}\n`;
`{record_frame i.live i.dbg ~label:label_after}\n`; 1
`{record_frame i.live false i.dbg ~label:label_after}\n`; 1
end else begin
` mov lr, pc\n`;
` bx {emit_reg i.arg.(0)}\n`;
`{record_frame i.live i.dbg ~label:label_after}\n`; 2
`{record_frame i.live false i.dbg ~label:label_after}\n`; 2
end
| Lop(Icall_imm { func; label_after; }) ->
` {emit_call func}\n`;
`{record_frame i.live i.dbg ~label:label_after}\n`; 1
`{record_frame i.live false i.dbg ~label:label_after}\n`; 1
| Lop(Itailcall_ind { label_after = _; }) ->
output_epilogue begin fun () ->
if !contains_calls then
@ -475,7 +476,7 @@ let emit_instr i =
| Lop(Iextcall { func; alloc = true; label_after; }) ->
let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) func in
` {emit_call "caml_c_call"}\n`;
`{record_frame i.live i.dbg ~label:label_after}\n`;
`{record_frame i.live false i.dbg ~label:label_after}\n`;
1 + ninstr
| Lop(Istackoffset n) ->
assert (n mod 8 = 0);
@ -547,7 +548,7 @@ let emit_instr i =
` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1
| Lop(Ialloc { words = n; label_after_call_gc; }) ->
let lbl_frame =
record_frame_label i.live i.dbg ?label:label_after_call_gc
record_frame_label i.live false i.dbg ?label:label_after_call_gc
in
if !fastcode_flag then begin
let lbl_redo = new_label() in
@ -796,7 +797,7 @@ let emit_instr i =
begin match !Clflags.debug, k with
| true, (Lambda.Raise_regular | Lambda.Raise_reraise) ->
` {emit_call "caml_raise_exn"}\n`;
`{record_frame Reg.Set.empty i.dbg}\n`; 1
`{record_frame Reg.Set.empty true i.dbg}\n`; 1
| false, _
| true, Lambda.Raise_notrace ->
` mov sp, trap_ptr\n`;

19
asmcomp/arm64/emit.mlp
View File

@ -121,7 +121,7 @@ let emit_addressing addr r =
(* Record live pointers at call points *)
let record_frame_label ?label live dbg =
let record_frame_label ?label live raise_ dbg =
let lbl =
match label with
| None -> new_label()
@ -142,11 +142,12 @@ let record_frame_label ?label live dbg =
{ fd_lbl = lbl;
fd_frame_size = frame_size();
fd_live_offset = !live_offset;
fd_raise = raise_;
fd_debuginfo = dbg } :: !frame_descriptors;
lbl
let record_frame ?label live dbg =
let lbl = record_frame_label ?label live dbg in `{emit_label lbl}:`
let record_frame ?label live raise_ dbg =
let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`
(* Record calls to the GC -- we've moved them out of the way *)
@ -174,7 +175,7 @@ let bound_error_sites = ref ([] : bound_error_call list)
let bound_error_label ?label dbg =
if !Clflags.debug || !bound_error_sites = [] then begin
let lbl_bound_error = new_label() in
let lbl_frame = record_frame_label ?label Reg.Set.empty dbg in
let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
bound_error_sites :=
{ bd_lbl = lbl_bound_error;
bd_frame_lbl = lbl_frame } :: !bound_error_sites;
@ -520,7 +521,7 @@ end)
let assembly_code_for_allocation ?label_after_call_gc i ~n ~far =
let lbl_frame =
record_frame_label ?label:label_after_call_gc i.live i.dbg
record_frame_label ?label:label_after_call_gc i.live false i.dbg
in
if !fastcode_flag then begin
let lbl_redo = new_label() in
@ -589,10 +590,10 @@ let emit_instr i =
emit_load_symbol_addr i.res.(0) s
| Lop(Icall_ind { label_after; }) ->
` blr {emit_reg i.arg.(0)}\n`;
`{record_frame i.live i.dbg ~label:label_after}\n`
`{record_frame i.live false i.dbg ~label:label_after}\n`
| Lop(Icall_imm { func; label_after; }) ->
` bl {emit_symbol func}\n`;
`{record_frame i.live i.dbg ~label:label_after}\n`
`{record_frame i.live false i.dbg ~label:label_after}\n`
| Lop(Itailcall_ind { label_after = _; }) ->
output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`)
| Lop(Itailcall_imm { func; label_after = _; }) ->
@ -605,7 +606,7 @@ let emit_instr i =
| Lop(Iextcall { func; alloc = true; label_after; }) ->
emit_load_symbol_addr reg_x15 func;
` bl {emit_symbol "caml_c_call"}\n`;
`{record_frame i.live i.dbg ~label:label_after}\n`
`{record_frame i.live false i.dbg ~label:label_after}\n`
| Lop(Istackoffset n) ->
assert (n mod 16 = 0);
emit_stack_adjustment (-n);
@ -859,7 +860,7 @@ let emit_instr i =
begin match !Clflags.debug, k with
| true, (Lambda.Raise_regular | Lambda.Raise_reraise) ->
` bl {emit_symbol "caml_raise_exn"}\n`;
`{record_frame Reg.Set.empty i.dbg}\n`
`{record_frame Reg.Set.empty true i.dbg}\n`
| false, _
| true, Lambda.Raise_notrace ->
` mov sp, {emit_reg reg_trap_ptr}\n`;

115
asmcomp/closure.ml
View File

@ -50,9 +50,9 @@ let rec build_closure_env env_param pos = function
and no longer in Cmmgen so that approximations stored in .cmx files
contain the right names if the -for-pack option is active. *)
let getglobal id =
let getglobal dbg id =
Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
[], Debuginfo.none)
[], dbg)
(* Check if a variable occurs in a [clambda] term. *)
@ -682,14 +682,15 @@ let rec is_pure = function
| Lconst _ -> true
| Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets |
Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false
| Lprim(_, args) -> List.for_all is_pure args
Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
| Lprim(_, args, _) -> List.for_all is_pure args
| Levent(lam, _ev) -> is_pure lam
| _ -> false
let warning_if_forced_inline ~loc ~attribute warning =
if attribute = Always_inline then
Location.prerr_warning loc (Warnings.Inlining_impossible warning)
Location.prerr_warning loc
(Warnings.Inlining_impossible warning)
(* Generate a direct application *)
@ -699,9 +700,10 @@ let direct_apply fundesc funct ufunct uargs ~loc ~attribute =
let app =
match fundesc.fun_inline, attribute with
| _, Never_inline | None, _ ->
let dbg = Debuginfo.from_location loc in
warning_if_forced_inline ~loc ~attribute
"Function information unavailable";
Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
Udirect_apply(fundesc.fun_label, app_args, dbg)
| Some(params, body), _ ->
bind_params loc fundesc.fun_float_const_prop params app_args body
in
@ -755,37 +757,6 @@ let global_approx = ref([||] : value_approximation array)
let function_nesting_depth = ref 0
let excessive_function_nesting_depth = 5
(* Decorate clambda term with debug information *)
let rec add_debug_info ev u =
let put_dinfo dinfo ev =
if Debuginfo.is_none dinfo then
Debuginfo.from_call ev
else dinfo
in
match ev.lev_kind with
| Lev_after _ ->
begin match u with
| Udirect_apply(lbl, args, dinfo) ->
Udirect_apply(lbl, args, put_dinfo dinfo ev)
| Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1),
args2, dinfo2) ->
Ugeneric_apply(Udirect_apply(lbl, args1, put_dinfo dinfo1 ev),
args2, put_dinfo dinfo2 ev)
| Ugeneric_apply(fn, args, dinfo) ->
Ugeneric_apply(fn, args, put_dinfo dinfo ev)
| Uprim(Praise k, args, dinfo) ->
Uprim(Praise k, args, put_dinfo dinfo ev)
| Uprim(p, args, dinfo) ->
Uprim(p, args, put_dinfo dinfo ev)
| Usend(kind, u1, u2, args, dinfo) ->
Usend(kind, u1, u2, args, put_dinfo dinfo ev)
| Usequence(u1, u2) ->
Usequence(u1, add_debug_info ev u2)
| _ -> u
end
| _ -> u
(* Uncurry an expression and explicitate closures.
Also return the approximation of the expression.
The approximation environment [fenv] maps idents to approximations.
@ -886,6 +857,7 @@ let rec close fenv cenv = function
ap_args=internal_args;
ap_inlined=Default_inline;
ap_specialised=Default_specialise};
loc;
attr = default_function_attribute})
in
let new_fun = iter first_args new_fun in
@ -895,19 +867,22 @@ let rec close fenv cenv = function
| ((ufunct, Value_closure(fundesc, _approx_res)), uargs)
when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
let dbg = Debuginfo.from_location loc in
warning_if_forced_inline ~loc ~attribute "Over-application";
(Ugeneric_apply(direct_apply ~loc ~attribute
fundesc funct ufunct first_args,
rem_args, Debuginfo.none),
rem_args, dbg),
Value_unknown)
| ((ufunct, _), uargs) ->
let dbg = Debuginfo.from_location loc in
warning_if_forced_inline ~loc ~attribute "Unknown function";
(Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown)
(Ugeneric_apply(ufunct, uargs, dbg), Value_unknown)
end
| Lsend(kind, met, obj, args, _) ->
| Lsend(kind, met, obj, args, loc) ->
let (umet, _) = close fenv cenv met in
let (uobj, _) = close fenv cenv obj in
(Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none),
let dbg = Debuginfo.from_location loc in
(Usend(kind, umet, uobj, close_list fenv cenv args, dbg),
Value_unknown)
| Llet(str, kind, id, lam, body) ->
let (ulam, alam) = close_named fenv cenv id lam in
@ -955,35 +930,40 @@ let rec close fenv cenv = function
let (ubody, approx) = close fenv_body cenv body in
(Uletrec(udefs, ubody), approx)
end
| Lprim(Pdirapply loc,[funct;arg])
| Lprim(Prevapply loc,[arg;funct]) ->
| Lprim(Pdirapply,[funct;arg], loc)
| Lprim(Prevapply,[arg;funct], loc) ->
close fenv cenv (Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=funct;
ap_args=[arg];
ap_inlined=Default_inline;
ap_specialised=Default_specialise})
| Lprim(Pgetglobal id, []) as lam ->
| Lprim(Pgetglobal id, [], loc) as lam ->
let dbg = Debuginfo.from_location loc in
check_constant_result lam
(getglobal id)
(getglobal dbg id)
(Compilenv.global_approx id)
| Lprim(Pfield n, [lam]) ->
| Lprim(Pfield n, [lam], loc) ->
let (ulam, approx) = close fenv cenv lam in
check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none))
let dbg = Debuginfo.from_location loc in
check_constant_result lam (Uprim(Pfield n, [ulam], dbg))
(field_approx n approx)
| Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, []); lam]) ->
| Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc) ->
let (ulam, approx) = close fenv cenv lam in
if approx <> Value_unknown then
(!global_approx).(n) <- approx;
(Uprim(Psetfield(n, is_ptr, init), [getglobal id; ulam], Debuginfo.none),
let dbg = Debuginfo.from_location loc in
(Uprim(Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg),
Value_unknown)
| Lprim(Praise k, [Levent(arg, ev)]) ->
| Lprim(Praise k, [arg], loc) ->
let (ulam, _approx) = close fenv cenv arg in
(Uprim(Praise k, [ulam], Debuginfo.from_raise ev),
let dbg = Debuginfo.from_location loc in
(Uprim(Praise k, [ulam], dbg),
Value_unknown)
| Lprim(p, args) ->
| Lprim(p, args, loc) ->
let dbg = Debuginfo.from_location loc in
simplif_prim !Clflags.float_const_prop
p (close_list_approx fenv cenv args) Debuginfo.none
p (close_list_approx fenv cenv args) dbg
| Lswitch(arg, sw) ->
let fn fail =
let (uarg, _) = close fenv cenv arg in
@ -1014,7 +994,7 @@ let rec close fenv cenv = function
Ucatch (i,[],ubody,uhandler),Value_unknown
else fn fail
end
| Lstringswitch(arg,sw,d) ->
| Lstringswitch(arg,sw,d,_) ->
let uarg,_ = close fenv cenv arg in
let usw =
List.map
@ -1064,9 +1044,8 @@ let rec close fenv cenv = function
| Lassign(id, lam) ->
let (ulam, _) = close fenv cenv lam in
(Uassign(id, ulam), Value_unknown)
| Levent(lam, ev) ->
let (ulam, approx) = close fenv cenv lam in
(add_debug_info ev ulam, approx)
| Levent(lam, _) ->
close fenv cenv lam
| Lifused _ ->
assert false
@ -1096,8 +1075,8 @@ and close_functions fenv cenv fun_defs =
List.flatten
(List.map
(function
| (id, Lfunction{kind; params; body; attr}) ->
Simplif.split_default_wrapper id kind params body attr
| (id, Lfunction{kind; params; body; attr; loc}) ->
Simplif.split_default_wrapper id kind params body attr loc
| _ -> assert false
)
fun_defs)
@ -1120,7 +1099,7 @@ and close_functions fenv cenv fun_defs =
let uncurried_defs =
List.map
(function
(id, Lfunction{kind; params; body}) ->
(id, Lfunction{kind; params; body; loc}) ->
let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in
let arity = List.length params in
let fundesc =
@ -1129,20 +1108,21 @@ and close_functions fenv cenv fun_defs =
fun_closed = initially_closed;
fun_inline = None;
fun_float_const_prop = !Clflags.float_const_prop } in
(id, params, body, fundesc)
let dbg = Debuginfo.from_location loc in
(id, params, body, fundesc, dbg)
| (_, _) -> fatal_error "Closure.close_functions")
fun_defs in
(* Build an approximate fenv for compiling the functions *)
let fenv_rec =
List.fold_right
(fun (id, _params, _body, fundesc) fenv ->
(fun (id, _params, _body, fundesc, _dbg) fenv ->
Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv)
uncurried_defs fenv in
(* Determine the offsets of each function's closure in the shared block *)
let env_pos = ref (-1) in
let clos_offsets =
List.map
(fun (_id, _params, _body, fundesc) ->
(fun (_id, _params, _body, fundesc, _dbg) ->
let pos = !env_pos + 1 in
env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
pos)
@ -1152,16 +1132,13 @@ and close_functions fenv cenv fun_defs =
does not use its environment parameter is invalidated. *)
let useless_env = ref initially_closed in
(* Translate each function definition *)
let clos_fundef (id, params, body, fundesc) env_pos =
let dbg = match body with
| Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev
| _ -> Debuginfo.none in
let clos_fundef (id, params, body, fundesc, dbg) env_pos =
let env_param = Ident.create "env" in
let cenv_fv =
build_closure_env env_param (fv_pos - env_pos) fv in
let cenv_body =
List.fold_right2
(fun (id, _params, _body, _fundesc) pos env ->
(fun (id, _params, _body, _fundesc, _dbg) pos env ->
Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
uncurried_defs clos_offsets cenv_fv in
let (ubody, approx) = close fenv_rec cenv_body body in
@ -1211,7 +1188,7 @@ and close_functions fenv cenv fun_defs =
recompile *)
Compilenv.backtrack snap; (* PR#6337 *)
List.iter
(fun (_id, _params, _body, fundesc) ->
(fun (_id, _params, _body, fundesc, _dbg) ->
fundesc.fun_closed <- false;
fundesc.fun_inline <- None;
)

80
asmcomp/emitaux.ml
View File

@ -15,8 +15,6 @@
(* Common functions for emitting assembly code *)
open Debuginfo
let output_channel = ref stdout
let emit_string s = output_string !output_channel s
@ -111,6 +109,7 @@ type frame_descr =
{ fd_lbl: int; (* Return address *)
fd_frame_size: int; (* Size of stack frame *)
fd_live_offset: int list; (* Offsets/regs of live addresses *)
fd_raise: bool; (* Is frame for a raise? *)
fd_debuginfo: Debuginfo.t } (* Location, if any *)
let frame_descriptors = ref([] : frame_descr list)
@ -137,19 +136,22 @@ let emit_frames a =
lbl
in
let debuginfos = Hashtbl.create 7 in
let rec label_debuginfos key =
let rec label_debuginfos rs rdbg =
let key = (rs, rdbg) in
try fst (Hashtbl.find debuginfos key)
with Not_found ->
let lbl = Cmm.new_label () in
let next = match key with
| _d, (d' :: ds') -> Some (label_debuginfos (d',ds'))
| _d, [] -> None
let next =
match rdbg with
| [] -> assert false
| _ :: [] -> None
| _ :: ((_ :: _) as rdbg') -> Some (label_debuginfos false rdbg')
in
Hashtbl.add debuginfos key (lbl, next);
lbl
in
let emit_debuginfo_label d =
a.efa_data_label (label_debuginfos (Debuginfo.unroll_inline_chain d))
let emit_debuginfo_label rs rdbg =
a.efa_data_label (label_debuginfos rs rdbg)
in
let emit_frame fd =
a.efa_code_label fd.fd_lbl;
@ -159,35 +161,32 @@ let emit_frames a =
a.efa_16 (List.length fd.fd_live_offset);
List.iter a.efa_16 fd.fd_live_offset;
a.efa_align Arch.size_addr;
if not (Debuginfo.is_none fd.fd_debuginfo) then
emit_debuginfo_label fd.fd_debuginfo
match List.rev fd.fd_debuginfo with
| [] -> ()
| _ :: _ as rdbg -> emit_debuginfo_label fd.fd_raise rdbg
in
let emit_filename name lbl =
a.efa_def_label lbl;
a.efa_string name;
a.efa_align Arch.size_addr
in
let pack_info d =
let line = min 0xFFFFF d.dinfo_line
and char_start = min 0xFF d.dinfo_char_start
and char_end = min 0x3FF d.dinfo_char_end
and kind = match d.dinfo_kind with
| Dinfo_call -> 0
| Dinfo_raise -> 1
| Dinfo_inline _ ->
assert false (* Should disappear after unrolling inline chain *)
in
let pack_info fd_raise d =
let line = min 0xFFFFF d.Debuginfo.dinfo_line
and char_start = min 0xFF d.Debuginfo.dinfo_char_start
and char_end = min 0x3FF d.Debuginfo.dinfo_char_end
and kind = if fd_raise then 1 else 0 in
Int64.(add (shift_left (of_int line) 44)
(add (shift_left (of_int char_start) 36)
(add (shift_left (of_int char_end) 26)
(of_int kind))))
in
let emit_debuginfo (d,_) (lbl,next) =
let emit_debuginfo (rs, rdbg) (lbl,next) =
let d = List.hd rdbg in
a.efa_align Arch.size_addr;
a.efa_def_label lbl;
let info = pack_info d in
let info = pack_info rs d in
a.efa_label_rel
(label_filename d.dinfo_file)
(label_filename d.Debuginfo.dinfo_file)
(Int64.to_int32 info);
a.efa_32 (Int64.to_int32 (Int64.shift_right info 32));
begin match next with
@ -258,25 +257,24 @@ let reset_debug_info () =
(* We only diplay .file if the file has not been seen before. We
display .loc for every instruction. *)
let emit_debug_info_gen dbg file_emitter loc_emitter =
let dbg, _ = Debuginfo.unroll_inline_chain dbg in
if is_cfi_enabled () &&
(!Clflags.debug || Config.with_frame_pointers)
&& dbg.Debuginfo.dinfo_line > 0 (* PR#6243 *)
then begin
let { Debuginfo.
dinfo_line = line;
dinfo_char_start = col;
dinfo_file = file_name;
} = dbg in
let file_num =
try List.assoc file_name !file_pos_nums
with Not_found ->
let file_num = !file_pos_num_cnt in
incr file_pos_num_cnt;
file_emitter ~file_num ~file_name;
file_pos_nums := (file_name,file_num) :: !file_pos_nums;
file_num in
loc_emitter ~file_num ~line ~col;
(!Clflags.debug || Config.with_frame_pointers) then begin
match List.rev dbg with
| [] -> ()
| { Debuginfo.dinfo_line = line;
dinfo_char_start = col;
dinfo_file = file_name; } :: _ ->
if line > 0 then begin (* PR#6243 *)
let file_num =
try List.assoc file_name !file_pos_nums
with Not_found ->
let file_num = !file_pos_num_cnt in
incr file_pos_num_cnt;
file_emitter ~file_num ~file_name;
file_pos_nums := (file_name,file_num) :: !file_pos_nums;
file_num in
loc_emitter ~file_num ~line ~col;
end
end
let emit_debug_info dbg =

1
asmcomp/emitaux.mli
View File

@ -42,6 +42,7 @@ type frame_descr =
{ fd_lbl: int; (* Return address *)
fd_frame_size: int; (* Size of stack frame *)
fd_live_offset: int list; (* Offsets/regs of live addresses *)
fd_raise: bool; (* Is frame for a raise? *)
fd_debuginfo: Debuginfo.t } (* Location, if any *)
val frame_descriptors : frame_descr list ref

20
asmcomp/flambda_to_clambda.ml
View File

@ -230,22 +230,6 @@ let to_clambda_const env (const : Flambda.constant_defining_value_block_field)
| Const (Char c) -> Uconst_int (Char.code c)
| Const (Const_pointer i) -> Uconst_ptr i
(* CR-someday mshinwell: We should improve debug info / location handling
so that we don't need to do this. *)
(* Erase debug info created with high probability by [Debuginfo.from_filename]
(currently only used for emission of warning 59, which happens prior to
this pass). Failure to do this will cause erroneous empty frames in
backtraces. *)
let erase_empty_debuginfo (dbg : Debuginfo.t) =
if dbg.dinfo_kind = Debuginfo.Dinfo_call
&& dbg.dinfo_line = 0
&& dbg.dinfo_char_start = 0
&& dbg.dinfo_char_end = 0
then
Debuginfo.none
else
dbg
let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
match flam with
| Var var -> subst_var env var
@ -409,19 +393,15 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
[check_field (check_closure ulam (Expr (Var closure))) pos (Some named)],
Debuginfo.none)
| Prim (Pfield index, [block], dbg) ->
let dbg = erase_empty_debuginfo dbg in
Uprim (Pfield index, [check_field (subst_var env block) index None], dbg)
| Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
let dbg = erase_empty_debuginfo dbg in
Uprim (Psetfield (index, maybe_ptr, init), [
check_field (subst_var env block) index None;
subst_var env new_value;
], dbg)
| Prim (Popaque, args, dbg) ->
let dbg = erase_empty_debuginfo dbg in
Uprim (Pidentity, subst_vars env args, dbg)
| Prim (p, args, dbg) ->
let dbg = erase_empty_debuginfo dbg in
Uprim (p, subst_vars env args, dbg)
| Expr expr -> to_clambda t env expr

24
asmcomp/i386/emit.mlp
View File

@ -193,7 +193,7 @@ let addressing addr typ i n =
(* Record live pointers at call points *)
let record_frame_label ?label live dbg =
let record_frame_label ?label live raise_ dbg =
let lbl =
match label with
| None -> new_label()
@ -214,11 +214,12 @@ let record_frame_label ?label live dbg =
{ fd_lbl = lbl;
fd_frame_size = frame_size();
fd_live_offset = !live_offset;
fd_raise = raise_;
fd_debuginfo = dbg } :: !frame_descriptors;
lbl
let record_frame ?label live dbg =
let lbl = record_frame_label ?label live dbg in
let record_frame ?label live raise_ dbg =
let lbl = record_frame_label ?label live raise_ dbg in
def_label lbl
(* Record calls to the GC -- we've moved them out of the way *)
@ -250,7 +251,7 @@ let bound_error_call = ref 0
let bound_error_label ?label dbg =
if !Clflags.debug then begin
let lbl_bound_error = new_label() in
let lbl_frame = record_frame_label ?label Reg.Set.empty dbg in
let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
bound_error_sites :=
{ bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
lbl_bound_error
@ -526,11 +527,11 @@ let emit_instr fallthrough i =
I.mov (immsym s) (reg i.res.(0))
| Lop(Icall_ind { label_after; }) ->
I.call (reg i.arg.(0));
record_frame i.live i.dbg ~label:label_after
record_frame i.live false i.dbg ~label:label_after
| Lop(Icall_imm { func; label_after; }) ->
add_used_symbol func;
emit_call func;
record_frame i.live i.dbg ~label:label_after
record_frame i.live false i.dbg ~label:label_after
| Lop(Itailcall_ind { label_after = _; }) ->
output_epilogue begin fun () ->
I.jmp (reg i.arg.(0))
@ -556,7 +557,7 @@ let emit_instr fallthrough i =
(emit_symbol func))) eax
end;
emit_call "caml_c_call";
record_frame i.live i.dbg ~label:label_after
record_frame i.live false i.dbg ~label:label_after
end else begin
if system <> S_macosx then
emit_call func
@ -622,7 +623,7 @@ let emit_instr fallthrough i =
I.mov eax (sym32 "caml_young_ptr");
I.cmp (sym32 "caml_young_limit") eax;
let lbl_call_gc = new_label() in
let lbl_frame = record_frame_label i.live Debuginfo.none in
let lbl_frame = record_frame_label i.live false Debuginfo.none in
I.jb (label lbl_call_gc);
I.lea (mem32 NONE 4 RAX) (reg i.res.(0));
call_gc_sites :=
@ -639,7 +640,8 @@ let emit_instr fallthrough i =
emit_call "caml_allocN"
end;
let label =
record_frame_label ?label:label_after_call_gc i.live Debuginfo.none
record_frame_label ?label:label_after_call_gc i.live false
Debuginfo.none
in
def_label label;
I.lea (mem32 NONE 4 RAX) (reg i.res.(0))
@ -879,10 +881,10 @@ let emit_instr fallthrough i =
begin match !Clflags.debug, k with
| true, Lambda.Raise_regular ->
emit_call "caml_raise_exn";
record_frame Reg.Set.empty i.dbg
record_frame Reg.Set.empty true i.dbg
| true, Lambda.Raise_reraise ->
emit_call "caml_reraise_exn";
record_frame Reg.Set.empty i.dbg
record_frame Reg.Set.empty true i.dbg
| false, _
| true, Lambda.Raise_notrace ->
I.mov (sym32 "caml_exception_pointer") esp;

29
asmcomp/power/emit.mlp
View File

@ -303,7 +303,7 @@ let adjust_stack_offset delta =
(* Record live pointers at call points *)
let record_frame ?label live dbg =
let record_frame ?label live raise_ dbg =
let lbl =
match label with
| None -> new_label()
@ -324,6 +324,7 @@ let record_frame ?label live dbg =
{ fd_lbl = lbl;
fd_frame_size = frame_size();
fd_live_offset = !live_offset;
fd_raise = raise_;
fd_debuginfo = dbg } :: !frame_descriptors;
`{emit_label lbl}:\n`
@ -585,26 +586,26 @@ let emit_instr i =
| ELF32 ->
` mtctr {emit_reg i.arg.(0)}\n`;
` bctrl\n`;
record_frame i.live i.dbg ~label:label_after
record_frame i.live false i.dbg ~label:label_after
| ELF64v1 ->
` ld 0, 0({emit_reg i.arg.(0)})\n`; (* code pointer *)
` mtctr 0\n`;
` ld 2, 8({emit_reg i.arg.(0)})\n`; (* TOC for callee *)
` bctrl\n`;
record_frame i.live i.dbg ~label:label_after;
record_frame i.live false i.dbg ~label:label_after;
emit_reload_toc()
| ELF64v2 ->
` mtctr {emit_reg i.arg.(0)}\n`;
` mr 12, {emit_reg i.arg.(0)}\n`; (* addr of fn in r12 *)
` bctrl\n`;
record_frame i.live i.dbg ~label:label_after;
record_frame i.live false i.dbg ~label:label_after;
emit_reload_toc()
end
| Lop(Icall_imm { func; label_after; }) ->
begin match abi with
| ELF32 ->
emit_call func;
record_frame i.live i.dbg ~label:label_after
record_frame i.live false i.dbg ~label:label_after
| ELF64v1 | ELF64v2 ->
(* For PPC64, we cannot just emit a "bl s; nop" sequence, because
of the following scenario:
@ -624,7 +625,7 @@ let emit_instr i =
Cost: 3 instructions if same TOC, 7 if different TOC.
Let's try option 2. *)
emit_call func;
record_frame i.live i.dbg ~label:label_after;
record_frame i.live false i.dbg ~label:label_after;
` nop\n`;
emit_reload_toc()
end
@ -684,11 +685,11 @@ let emit_instr i =
` addis 28, 0, {emit_upper emit_symbol func}\n`;
` addi 28, 28, {emit_lower emit_symbol func}\n`;
emit_call "caml_c_call";
record_frame i.live i.dbg
record_frame i.live false i.dbg
| ELF64v1 | ELF64v2 ->
emit_tocload emit_gpr 28 (TocSym func);
emit_call "caml_c_call";
record_frame i.live i.dbg;
record_frame i.live false i.dbg;
` nop\n`
end
| Lop(Istackoffset n) ->
@ -730,7 +731,7 @@ let emit_instr i =
` addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`;
` bltl {emit_label !call_gc_label}\n`;
(* Exactly 4 instructions after the beginning of the alloc sequence *)
record_frame i.live Debuginfo.none
record_frame i.live false Debuginfo.none
| Lop(Ispecific(Ialloc_far { words = n; label_after_call_gc; })) ->
if !call_gc_label = 0 then begin
match label_after_call_gc with
@ -743,7 +744,7 @@ let emit_instr i =
` bge {emit_label lbl}\n`;
` bl {emit_label !call_gc_label}\n`;
(* Exactly 4 instructions after the beginning of the alloc sequence *)
record_frame i.live Debuginfo.none;
record_frame i.live false Debuginfo.none;
`{emit_label lbl}: addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`
| Lop(Iintop Isub) -> (* subfc has swapped arguments *)
` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
@ -762,7 +763,7 @@ let emit_instr i =
end
| Lop(Iintop (Icheckbound { label_after_error; })) ->
if !Clflags.debug then
record_frame Reg.Set.empty i.dbg ?label:label_after_error;
record_frame Reg.Set.empty false i.dbg ?label:label_after_error;
` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
| Lop(Iintop op) ->
let instr = name_for_intop op in
@ -780,7 +781,7 @@ let emit_instr i =
end
| Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
if !Clflags.debug then
record_frame Reg.Set.empty i.dbg ?label:label_after_error;
record_frame Reg.Set.empty false i.dbg ?label:label_after_error;
` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n`
| Lop(Iintop_imm(op, n)) ->
let instr = name_for_intop_imm op in
@ -948,11 +949,11 @@ let emit_instr i =
begin match !Clflags.debug, k with
| true, Lambda.Raise_regular ->
emit_call "caml_raise_exn";
record_frame Reg.Set.empty i.dbg;
record_frame Reg.Set.empty true i.dbg;
emit_call_nop()
| true, Lambda.Raise_reraise ->
emit_call "caml_reraise_exn";
record_frame Reg.Set.empty i.dbg;
record_frame Reg.Set.empty true i.dbg;
emit_call_nop()
| false, _
| true, Lambda.Raise_notrace ->

19
asmcomp/s390x/emit.mlp
View File

@ -154,7 +154,7 @@ let emit_set_comp cmp res =
(* Record live pointers at call points *)
let record_frame ?label live dbg =
let record_frame ?label live raise_ dbg =
let lbl =
match label with
| None -> new_label()
@ -175,6 +175,7 @@ let record_frame ?label live dbg =
{ fd_lbl = lbl;
fd_frame_size = frame_size();
fd_live_offset = !live_offset;
fd_raise = raise_;
fd_debuginfo = dbg } :: !frame_descriptors;
lbl
@ -203,7 +204,7 @@ let bound_error_call = ref 0
let bound_error_label ?label dbg =
if !Clflags.debug then begin
let lbl_bound_error = new_label() in
let lbl_frame = record_frame ?label Reg.Set.empty dbg in
let lbl_frame = record_frame ?label Reg.Set.empty false dbg in
bound_error_sites :=
{ bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
lbl_bound_error
@ -330,7 +331,7 @@ let emit_instr i =
` larl {emit_reg i.res.(0)}, {emit_symbol s}\n`;
| Lop(Icall_ind { label_after; }) ->
` basr %r14, {emit_reg i.arg.(0)}\n`;
let lbl = record_frame i.live i.dbg ~label:label_after in
let lbl = record_frame i.live false i.dbg ~label:label_after in
`{emit_label lbl}:\n`
| Lop(Icall_imm { func; label_after; }) ->
@ -338,7 +339,7 @@ let emit_instr i =
` brasl %r14, {emit_symbol func}@PLT\n`
else
` brasl %r14, {emit_symbol func}\n`;
let lbl = record_frame i.live i.dbg ~label:label_after in
let lbl = record_frame i.live false i.dbg ~label:label_after in
`{emit_label lbl}:\n`;
| Lop(Itailcall_ind { label_after = _; }) ->
let n = frame_size() in
@ -369,7 +370,7 @@ let emit_instr i =
` larl %r7, {emit_symbol func}\n`;
` brasl %r14, {emit_symbol "caml_c_call"}\n`
end;
let lbl = record_frame i.live i.dbg ~label:label_after in
let lbl = record_frame i.live false i.dbg ~label:label_after in
`{emit_label lbl}:\n`;
end else begin
if !pic_code then
@ -415,7 +416,9 @@ let emit_instr i =
| Lop(Ialloc { words = n; label_after_call_gc; }) ->
let lbl_redo = new_label() in
let lbl_call_gc = new_label() in
let lbl_frame = record_frame i.live i.dbg ?label:label_after_call_gc in
let lbl_frame =
record_frame i.live false i.dbg ?label:label_after_call_gc
in
call_gc_sites :=
{ gc_lbl = lbl_call_gc;
gc_return_lbl = lbl_redo;
@ -615,11 +618,11 @@ let emit_instr i =
begin match !Clflags.debug, k with
| true, Lambda.Raise_regular ->
` brasl %r14, {emit_symbol "caml_raise_exn"}\n`;
let lbl = record_frame Reg.Set.empty i.dbg in
let lbl = record_frame Reg.Set.empty true i.dbg in
`{emit_label lbl}:\n`
| true, Lambda.Raise_reraise ->
` brasl %r14, {emit_symbol "caml_reraise_exn"}\n`;
let lbl = record_frame Reg.Set.empty i.dbg in
let lbl = record_frame Reg.Set.empty true i.dbg in
`{emit_label lbl}:\n`
| false, _
| true, Lambda.Raise_notrace ->

61
bytecomp/bytegen.ml
View File

@ -136,7 +136,7 @@ type rhs_kind =
let rec check_recordwith_updates id e =
match e with
| Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _]), cont)
| Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _], _), cont)
-> id2 = id && check_recordwith_updates id cont
| Lvar id2 -> id2 = id
| _ -> false
@ -146,7 +146,7 @@ let rec size_of_lambda = function
| Lfunction{params} as funct ->
RHS_function (1 + IdentSet.cardinal(free_variables funct),
List.length params)
| Llet (Strict, _k, id, Lprim (Pduprecord (kind, size), _), body)
| Llet (Strict, _k, id, Lprim (Pduprecord (kind, size), _, _), body)
when check_recordwith_updates id body ->
begin match kind with
| Record_regular | Record_inlined _ -> RHS_block size
@ -155,17 +155,17 @@ let rec size_of_lambda = function
end
| Llet(_str, _k, _id, _arg, body) -> size_of_lambda body
| Lletrec(_bindings, body) -> size_of_lambda body
| Lprim(Pmakeblock _, args) -> RHS_block (List.length args)
| Lprim (Pmakearray ((Paddrarray|Pintarray), _), args) ->
| Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args)
| Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) ->
RHS_block (List.length args)
| Lprim (Pmakearray (Pfloatarray, _), args) ->
| Lprim (Pmakearray (Pfloatarray, _), args, _) ->
RHS_floatblock (List.length args)
| Lprim (Pmakearray (Pgenarray, _), _) -> assert false
| Lprim (Pduprecord ((Record_regular | Record_inlined _), size), _) ->
| Lprim (Pmakearray (Pgenarray, _), _, _) -> assert false
| Lprim (Pduprecord ((Record_regular | Record_inlined _), size), _, _) ->
RHS_block size
| Lprim (Pduprecord (Record_extension, size), _) ->
| Lprim (Pduprecord (Record_extension, size), _, _) ->
RHS_block (size + 1)
| Lprim (Pduprecord (Record_float, size), _) -> RHS_floatblock size
| Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size
| Levent (lam, _) -> size_of_lambda lam
| Lsequence (_lam, lam') -> size_of_lambda lam'
| _ -> RHS_nonrec
@ -576,12 +576,12 @@ let rec comp_expr env exp sz cont =
in
comp_init env sz decl_size
end
| Lprim((Pidentity | Popaque), [arg]) ->
| Lprim((Pidentity | Popaque), [arg], _) ->
comp_expr env arg sz cont
| Lprim(Pignore, [arg]) ->
| Lprim(Pignore, [arg], _) ->
comp_expr env arg sz (add_const_unit cont)
| Lprim(Pdirapply loc, [func;arg])
| Lprim(Prevapply loc, [arg;func]) ->
| Lprim(Pdirapply, [func;arg], loc)
| Lprim(Prevapply, [arg;func], loc) ->
let exp = Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=func;
@ -589,14 +589,14 @@ let rec comp_expr env exp sz cont =
ap_inlined=Default_inline;
ap_specialised=Default_specialise} in
comp_expr env exp sz cont
| Lprim(Pnot, [arg]) ->
| Lprim(Pnot, [arg], _) ->
let newcont =
match cont with
Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1
| Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1
| _ -> Kboolnot :: cont in
comp_expr env arg sz newcont
| Lprim(Psequand, [exp1; exp2]) ->
| Lprim(Psequand, [exp1; exp2], _) ->
begin match cont with
Kbranchifnot lbl :: _ ->
comp_expr env exp1 sz (Kbranchifnot lbl ::
@ -610,7 +610,7 @@ let rec comp_expr env exp sz cont =
comp_expr env exp1 sz (Kstrictbranchifnot lbl ::
comp_expr env exp2 sz cont1)
end
| Lprim(Psequor, [exp1; exp2]) ->
| Lprim(Psequor, [exp1; exp2], _) ->
begin match cont with
Kbranchif lbl :: _ ->
comp_expr env exp1 sz (Kbranchif lbl ::
@ -624,21 +624,21 @@ let rec comp_expr env exp sz cont =
comp_expr env exp1 sz (Kstrictbranchif lbl ::
comp_expr env exp2 sz cont1)
end
| Lprim(Praise k, [arg]) ->
| Lprim(Praise k, [arg], _) ->
comp_expr env arg sz (Kraise k :: discard_dead_code cont)
| Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))])
| Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))], _)
when is_immed n ->
comp_expr env arg sz (Koffsetint n :: cont)
| Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))])
| Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))], _)
when is_immed (-n) ->
comp_expr env arg sz (Koffsetint (-n) :: cont)
| Lprim (Poffsetint n, [arg])
| Lprim (Poffsetint n, [arg], _)
when not (is_immed n) ->
comp_expr env arg sz
(Kpush::
Kconst (Const_base (Const_int n))::
Kaddint::cont)
| Lprim(Pmakearray (kind, _), args) ->
| Lprim(Pmakearray (kind, _), args, _) ->
begin match kind with
Pintarray | Paddrarray ->
comp_args env args sz (Kmakeblock(List.length args, 0) :: cont)
@ -651,22 +651,23 @@ let rec comp_expr env exp sz cont =
(Kmakeblock(List.length args, 0) ::
Kccall("caml_make_array", 1) :: cont)
end
| Lprim (Pduparray (kind, mutability), [Lprim (Pmakearray (kind',_),args)]) ->
| Lprim (Pduparray (kind, mutability),
[Lprim (Pmakearray (kind',_),args,_)], loc) ->
assert (kind = kind');
comp_expr env (Lprim (Pmakearray (kind, mutability), args)) sz cont
| Lprim (Pduparray _, [arg]) ->
comp_expr env (Lprim (Pmakearray (kind, mutability), args, loc)) sz cont
| Lprim (Pduparray _, [arg], loc) ->
let prim_obj_dup =
Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
in
comp_expr env (Lprim (Pccall prim_obj_dup, [arg])) sz cont
| Lprim (Pduparray _, _) ->
comp_expr env (Lprim (Pccall prim_obj_dup, [arg], loc)) sz cont
| Lprim (Pduparray _, _, _) ->
Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg"
(* Integer first for enabling futher optimization (cf. emitcode.ml) *)
| Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) ->
| Lprim (Pintcomp c, [arg ; (Lconst _ as k)], _) ->
let p = Pintcomp (commute_comparison c)
and args = [k ; arg] in
comp_args env args sz (comp_primitive p args :: cont)
| Lprim(p, args) ->
| Lprim(p, args, _) ->
comp_args env args sz (comp_primitive p args :: cont)
| Lstaticcatch (body, (i, vars) , handler) ->
let nvars = List.length vars in
@ -792,8 +793,8 @@ let rec comp_expr env exp sz cont =
lbl_consts.(i) <- lbls.(act_consts.(i))
done;
comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
| Lstringswitch (arg,sw,d) ->
comp_expr env (Matching.expand_stringswitch arg sw d) sz cont
| Lstringswitch (arg,sw,d,loc) ->
comp_expr env (Matching.expand_stringswitch loc arg sw d) sz cont
| Lassign(id, expr) ->
begin try
let pos = Ident.find_same id env.ce_stack in

119
bytecomp/debuginfo.ml
View File

@ -1,119 +0,0 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Lexing
open Location
type kind = Dinfo_call | Dinfo_raise | Dinfo_inline of t
and t = {
dinfo_kind: kind;
dinfo_file: string;
dinfo_line: int;
dinfo_char_start: int;
dinfo_char_end: int
}
let none = {
dinfo_kind = Dinfo_call;
dinfo_file = "";
dinfo_line = 0;
dinfo_char_start = 0;
dinfo_char_end = 0
}
(* PR#5643: cannot use (==) because Debuginfo values are marshalled *)
let is_none t =
t = none
let to_string d =
let rec to_list d =
if is_none d then []
else
let s =
Printf.sprintf "%s:%d,%d-%d"
d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end
in
match d.dinfo_kind with
| Dinfo_inline d' -> s :: to_list d'
| _ -> [s]
in
match to_list d with
| [] -> ""
| ds -> "{" ^ String.concat ";" ds ^ "}"
let from_filename kind filename = {
dinfo_kind = kind;
dinfo_file = filename;
dinfo_line = 0;
dinfo_char_start = 0;
dinfo_char_end = 0
}
let from_location kind loc =
if loc == Location.none then none else
{ dinfo_kind = kind;
dinfo_file = loc.loc_start.pos_fname;
dinfo_line = loc.loc_start.pos_lnum;
dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
dinfo_char_end =
if loc.loc_end.pos_fname = loc.loc_start.pos_fname
then loc.loc_end.pos_cnum - loc.loc_start.pos_bol
else loc.loc_start.pos_cnum - loc.loc_start.pos_bol }
let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc
let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc
let to_location d =
if is_none d then Location.none
else
let loc_start =
{ pos_fname = d.dinfo_file;
pos_lnum = d.dinfo_line;
pos_bol = 0;
pos_cnum = d.dinfo_char_start;
} in
let loc_end = { loc_start with pos_cnum = d.dinfo_char_end; } in
{ loc_ghost = false; loc_start; loc_end; }
let inline loc t =
if loc = Location.none then
t
else
from_location (Dinfo_inline t) loc
let concat dbg1 dbg2 =
if is_none dbg1 then dbg2
else if is_none dbg2 then dbg1
else
let rec aux dbg1 dbg2 =
match dbg1.dinfo_kind with
| Dinfo_call ->
{dbg1 with dinfo_kind = Dinfo_inline dbg2}
| Dinfo_raise ->
invalid_arg "Debuginfo.concat: inlining from a raise site"
| Dinfo_inline dbg1' ->
{dbg1 with dinfo_kind = Dinfo_inline (aux dbg1' dbg2)}
in
aux dbg1 dbg2
let unroll_inline_chain t =
let rec aux acc t = match t.dinfo_kind with
| Dinfo_inline t' ->
aux ({t with dinfo_kind = Dinfo_call} :: acc) t'
| _ -> t, acc
in
aux [] t

52
bytecomp/lambda.ml
View File

@ -45,8 +45,8 @@ type initialization_or_assignment =
type primitive =
Pidentity
| Pignore
| Prevapply of Location.t
| Pdirapply of Location.t
| Prevapply
| Pdirapply
| Ploc of loc_kind
(* Globals *)
| Pgetglobal of Ident.t
@ -214,9 +214,10 @@ type lambda =
| Lfunction of lfunction
| Llet of let_kind * value_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
| Lprim of primitive * lambda list * Location.t
| Lswitch of lambda * lambda_switch
| Lstringswitch of lambda * (string * lambda) list * lambda option
| Lstringswitch of
lambda * (string * lambda) list * lambda option * Location.t
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
@ -233,7 +234,8 @@ and lfunction =
{ kind: function_kind;
params: Ident.t list;
body: lambda;
attr: function_attribute; } (* specified with [@inline] attribute *)
attr: function_attribute; (* specified with [@inline] attribute *)
loc: Location.t; }
and lambda_apply =
{ ap_func : lambda;
@ -315,15 +317,16 @@ let make_key e =
let ex = tr_rec env ex in
let y = make_key x in
Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e)
| Lprim (p,es) ->
Lprim (p,tr_recs env es)
| Lprim (p,es,_) ->
Lprim (p,tr_recs env es, Location.none)
| Lswitch (e,sw) ->
Lswitch (tr_rec env e,tr_sw env sw)
| Lstringswitch (e,sw,d) ->
| Lstringswitch (e,sw,d,_) ->
Lstringswitch
(tr_rec env e,
List.map (fun (s,e) -> s,tr_rec env e) sw,
tr_opt env d)
tr_opt env d,
Location.none)
| Lstaticraise (i,es) ->
Lstaticraise (i,tr_recs env es)
| Lstaticcatch (e1,xs,e2) ->
@ -396,14 +399,14 @@ let iter f = function
| Lletrec(decl, body) ->
f body;
List.iter (fun (_id, exp) -> f exp) decl
| Lprim(_p, args) ->
| Lprim(_p, args, _loc) ->
List.iter f args
| Lswitch(arg, sw) ->
f arg;
List.iter (fun (_key, case) -> f case) sw.sw_consts;
List.iter (fun (_key, case) -> f case) sw.sw_blocks;
iter_opt f sw.sw_failaction
| Lstringswitch (arg,cases,default) ->
| Lstringswitch (arg,cases,default,_) ->
f arg ;
List.iter (fun (_,act) -> f act) cases ;
iter_opt f default
@ -500,9 +503,9 @@ let rec patch_guarded patch = function
let rec transl_normal_path = function
Pident id ->
if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
if Ident.global id then Lprim(Pgetglobal id, [], Location.none) else Lvar id
| Pdot(p, _s, pos) ->
Lprim(Pfield pos, [transl_normal_path p])
Lprim(Pfield pos, [transl_normal_path p], Location.none)
| Papply _ ->
fatal_error "Lambda.transl_path"
@ -533,19 +536,19 @@ let subst_lambda s lam =
| Lapply ap ->
Lapply{ap with ap_func = subst ap.ap_func;
ap_args = List.map subst ap.ap_args}
| Lfunction{kind; params; body; attr} ->
Lfunction{kind; params; body = subst body; attr}
| Lfunction{kind; params; body; attr; loc} ->
Lfunction{kind; params; body = subst body; attr; loc}
| Llet(str, k, id, arg, body) -> Llet(str, k, id, subst arg, subst body)
| Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
| Lprim(p, args) -> Lprim(p, List.map subst args)
| Lprim(p, args, loc) -> Lprim(p, List.map subst args, loc)
| Lswitch(arg, sw) ->
Lswitch(subst arg,
{sw with sw_consts = List.map subst_case sw.sw_consts;
sw_blocks = List.map subst_case sw.sw_blocks;
sw_failaction = subst_opt sw.sw_failaction; })
| Lstringswitch (arg,cases,default) ->
| Lstringswitch (arg,cases,default,loc) ->
Lstringswitch
(subst arg,List.map subst_strcase cases,subst_opt default)
(subst arg,List.map subst_strcase cases,subst_opt default,loc)
| Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args)
| Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
| Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
@ -581,14 +584,14 @@ let rec map f lam =
ap_inlined;
ap_specialised;
}
| Lfunction { kind; params; body; attr; } ->
Lfunction { kind; params; body = map f body; attr; }
| Lfunction { kind; params; body; attr; loc; } ->
Lfunction { kind; params; body = map f body; attr; loc; }
| Llet (str, k, v, e1, e2) ->
Llet (str, k, v, map f e1, map f e2)
| Lletrec (idel, e2) ->
Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2)
| Lprim (p, el) ->
Lprim (p, List.map (map f) el)
| Lprim (p, el, loc) ->
Lprim (p, List.map (map f) el, loc)
| Lswitch (e, sw) ->
Lswitch (map f e,
{ sw_numconsts = sw.sw_numconsts;
@ -597,11 +600,12 @@ let rec map f lam =
sw_blocks = List.map (fun (n, e) -> (n, map f e)) sw.sw_blocks;
sw_failaction = Misc.may_map (map f) sw.sw_failaction;
})
| Lstringswitch (e, sw, default) ->
| Lstringswitch (e, sw, default, loc) ->
Lstringswitch (
map f e,
List.map (fun (s, e) -> (s, map f e)) sw,
Misc.may_map (map f) default)
Misc.may_map (map f) default,
loc)
| Lstaticraise (i, args) ->
Lstaticraise (i, List.map (map f) args)
| Lstaticcatch (body, id, handler) ->

12
bytecomp/lambda.mli
View File

@ -48,8 +48,8 @@ type initialization_or_assignment =
type primitive =
Pidentity
| Pignore
| Prevapply of Location.t
| Pdirapply of Location.t
| Prevapply
| Pdirapply
| Ploc of loc_kind
(* Globals *)
| Pgetglobal of Ident.t
@ -230,11 +230,12 @@ type lambda =
| Lfunction of lfunction
| Llet of let_kind * value_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
| Lprim of primitive * lambda list * Location.t
| Lswitch of lambda * lambda_switch
(* switch on strings, clauses are sorted by string order,
strings are pairwise distinct *)
| Lstringswitch of lambda * (string * lambda) list * lambda option
| Lstringswitch of
lambda * (string * lambda) list * lambda option * Location.t
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
@ -251,7 +252,8 @@ and lfunction =
{ kind: function_kind;
params: Ident.t list;
body: lambda;
attr: function_attribute; } (* specified with [@inline] attribute *)
attr: function_attribute; (* specified with [@inline] attribute *)
loc : Location.t; }
and lambda_apply =
{ ap_func : lambda;

162
bytecomp/matching.ml
View File

@ -1286,11 +1286,11 @@ let divide_constant ctx m =
(* Matching against a constructor *)
let make_field_args binding_kind arg first_pos last_pos argl =
let make_field_args loc binding_kind arg first_pos last_pos argl =
let rec make_args pos =
if pos > last_pos
then argl
else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1)
else (Lprim(Pfield pos, [arg], loc), binding_kind) :: make_args (pos + 1)
in make_args first_pos
let get_key_constr = function
@ -1354,9 +1354,9 @@ let make_constr_matching p def ctx = function
(arg, Alias) :: argl
else match cstr.cstr_tag with
Cstr_constant _ | Cstr_block _ ->
make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl
make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl
| Cstr_extension _ ->
make_field_args Alias arg 1 cstr.cstr_arity argl in
make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in
{pm=
{cases = []; args = newargs;
default = make_default (matcher_constr cstr) def} ;
@ -1407,7 +1407,7 @@ let make_variant_matching_nonconst p lab def ctx = function
let def = make_default (matcher_variant_nonconst lab) def
and ctx = filter_ctx p ctx in
{pm=
{cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl;
{cases = []; args = (Lprim(Pfield 1, [arg], p.pat_loc), Alias) :: argl;
default=def} ;
ctx=ctx ;
pat = normalize_pat p}
@ -1486,7 +1486,9 @@ let get_mod_field modname field =
with Not_found ->
fatal_error ("Primitive "^modname^"."^field^" not found.")
in
Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])])
Lprim(Pfield p,
[Lprim(Pgetglobal mod_ident, [], Location.none)],
Location.none)
with Not_found -> fatal_error ("Module "^modname^" unavailable.")
)
@ -1510,16 +1512,17 @@ let inline_lazy_force_cond arg loc =
let tag = Ident.create "tag" in
let force_fun = Lazy.force code_force_lazy_block in
Llet(Strict, Pgenval, idarg, arg,
Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg]),
Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc),
Lifthenelse(
(* if (tag == Obj.forward_tag) then varg.(0) else ... *)
Lprim(Pintcomp Ceq,
[Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]),
Lprim(Pfield 0, [varg]),
[Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))],
loc),
Lprim(Pfield 0, [varg], loc),
Lifthenelse(
(* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
Lprim(Pintcomp Ceq,
[Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]),
[Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))], loc),
Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=force_fun;
@ -1535,13 +1538,13 @@ let inline_lazy_force_switch arg loc =
let force_fun = Lazy.force code_force_lazy_block in
Llet(Strict, Pgenval, idarg, arg,
Lifthenelse(
Lprim(Pisint, [varg]), varg,
Lprim(Pisint, [varg], loc), varg,
(Lswitch
(varg,
{ sw_numconsts = 0; sw_consts = [];
sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *)
sw_blocks =
[ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
[ (Obj.forward_tag, Lprim(Pfield 0, [varg], loc));
(Obj.lazy_tag,
Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
@ -1589,13 +1592,13 @@ let matcher_tuple arity p rem = match p.pat_desc with
| Tpat_var _ -> get_args_tuple arity omega rem
| _ -> get_args_tuple arity p rem
let make_tuple_matching arity def = function
let make_tuple_matching loc arity def = function
[] -> fatal_error "Matching.make_tuple_matching"
| (arg, _mut) :: argl ->
let rec make_args pos =
if pos >= arity
then argl
else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
else (Lprim(Pfield pos, [arg], loc), Alias) :: make_args (pos + 1) in
{cases = []; args = make_args 0 ;
default=make_default (matcher_tuple arity) def}
@ -1603,7 +1606,7 @@ let make_tuple_matching arity def = function
let divide_tuple arity p ctx pm =
divide_line
(filter_ctx p)
(make_tuple_matching arity)
(make_tuple_matching p.pat_loc arity)
(get_args_tuple arity) p ctx pm
(* Matching against a record pattern *)
@ -1626,7 +1629,7 @@ let matcher_record num_fields p rem = match p.pat_desc with
| Tpat_var _ -> get_args_record num_fields omega rem
| _ -> get_args_record num_fields p rem
let make_record_matching all_labels def = function
let make_record_matching loc all_labels def = function
[] -> fatal_error "Matching.make_record_matching"
| ((arg, _mut) :: argl) ->
let rec make_args pos =
@ -1642,7 +1645,7 @@ let make_record_matching all_labels def = function
match lbl.lbl_mut with
Immutable -> Alias
| Mutable -> StrictOpt in
(Lprim(access, [arg]), str) :: make_args(pos + 1)
(Lprim(access, [arg], loc), str) :: make_args(pos + 1)
end in
let nfields = Array.length all_labels in
let def= make_default (matcher_record nfields) def in
@ -1653,7 +1656,7 @@ let divide_record all_labels p ctx pm =
let get_args = get_args_record (Array.length all_labels) in
divide_line
(filter_ctx p)
(make_record_matching all_labels)
(make_record_matching p.pat_loc all_labels)
get_args
p ctx pm
@ -1680,7 +1683,9 @@ let make_array_matching kind p def ctx = function
let rec make_args pos =
if pos >= len
then argl
else (Lprim(Parrayrefu kind, [arg; Lconst(Const_base(Const_int pos))]),
else (Lprim(Parrayrefu kind,
[arg; Lconst(Const_base(Const_int pos))],
p.pat_loc),
StrictOpt) :: make_args (pos + 1) in
let def = make_default (matcher_array len) def
and ctx = filter_ctx p ctx in
@ -1731,7 +1736,7 @@ let bind_sw arg k = match arg with
(* Sequential equality tests *)
let make_string_test_sequence arg sw d =
let make_string_test_sequence loc arg sw d =
let d,sw = match d with
| None ->
begin match sw with
@ -1746,7 +1751,7 @@ let make_string_test_sequence arg sw d =
Lifthenelse
(Lprim
(prim_string_notequal,
[arg; Lconst (Const_immstring s)]),
[arg; Lconst (Const_immstring s)], loc),
k,lam))
sw d)
@ -1760,40 +1765,40 @@ let rec split k xs = match xs with
let zero_lam = Lconst (Const_base (Const_int 0))
let tree_way_test arg lt eq gt =
let tree_way_test loc arg lt eq gt =
Lifthenelse
(Lprim (Pintcomp Clt,[arg;zero_lam]),lt,
Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg]),gt,eq))
(Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt,
Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq))
(* Dichotomic tree *)
let rec do_make_string_test_tree arg sw delta d =
let rec do_make_string_test_tree loc arg sw delta d =
let len = List.length sw in
if len <= strings_test_threshold+delta then
make_string_test_sequence arg sw d
make_string_test_sequence loc arg sw d
else
let lt,(s,act),gt = split len sw in
bind_sw
(Lprim
(prim_string_compare,
[arg; Lconst (Const_immstring s)];))
[arg; Lconst (Const_immstring s)], loc;))
(fun r ->
tree_way_test r
(do_make_string_test_tree arg lt delta d)
tree_way_test loc r
(do_make_string_test_tree loc arg lt delta d)
act
(do_make_string_test_tree arg gt delta d))
(do_make_string_test_tree loc arg gt delta d))
(* Entry point *)
let expand_stringswitch arg sw d = match d with
let expand_stringswitch loc arg sw d = match d with
| None ->
bind_sw arg
(fun arg -> do_make_string_test_tree arg sw 0 None)
(fun arg -> do_make_string_test_tree loc arg sw 0 None)
| Some e ->
bind_sw arg
(fun arg ->
make_catch e
(fun d -> do_make_string_test_tree arg sw 1 (Some d)))
(fun d -> do_make_string_test_tree loc arg sw 1 (Some d)))
(**********************)
(* Generic test trees *)
@ -1857,24 +1862,24 @@ let rec cut n l =
[] -> raise (Invalid_argument "cut")
| a::l -> let l1,l2 = cut (n-1) l in a::l1, l2
let rec do_tests_fail fail tst arg = function
let rec do_tests_fail loc fail tst arg = function
| [] -> fail
| (c, act)::rem ->
Lifthenelse
(Lprim (tst, [arg ; Lconst (Const_base c)]),
do_tests_fail fail tst arg rem,
(Lprim (tst, [arg ; Lconst (Const_base c)], loc),
do_tests_fail loc fail tst arg rem,
act)
let rec do_tests_nofail tst arg = function
let rec do_tests_nofail loc tst arg = function
| [] -> fatal_error "Matching.do_tests_nofail"
| [_,act] -> act
| (c,act)::rem ->
Lifthenelse
(Lprim (tst, [arg ; Lconst (Const_base c)]),
do_tests_nofail tst arg rem,
(Lprim (tst, [arg ; Lconst (Const_base c)], loc),
do_tests_nofail loc tst arg rem,
act)
let make_test_sequence fail tst lt_tst arg const_lambda_list =
let make_test_sequence loc fail tst lt_tst arg const_lambda_list =
let const_lambda_list = sort_lambda_list const_lambda_list in
let hs,const_lambda_list,fail =
share_actions_tree const_lambda_list fail in
@ -1883,13 +1888,15 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list =
if List.length const_lambda_list >= 4 && lt_tst <> Pignore then
split_sequence const_lambda_list
else match fail with
| None -> do_tests_nofail tst arg const_lambda_list
| Some fail -> do_tests_fail fail tst arg const_lambda_list
| None -> do_tests_nofail loc tst arg const_lambda_list
| Some fail -> do_tests_fail loc fail tst arg const_lambda_list
and split_sequence const_lambda_list =
let list1, list2 =
cut (List.length const_lambda_list / 2) const_lambda_list in
Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]),
Lifthenelse(Lprim(lt_tst,
[arg; Lconst(Const_base (fst(List.hd list2)))],
loc),
make_test_sequence list1, make_test_sequence list2)
in
hs (make_test_sequence const_lambda_list)
@ -1907,10 +1914,10 @@ module SArg = struct
type act = Lambda.lambda
let make_prim p args = Lprim (p,args)
let make_prim p args = Lprim (p,args,Location.none)
let make_offset arg n = match n with
| 0 -> arg
| _ -> Lprim (Poffsetint n,[arg])
| _ -> Lprim (Poffsetint n,[arg],Location.none)
let bind arg body =
let newvar,newarg = match arg with
@ -1920,8 +1927,8 @@ module SArg = struct
newvar,Lvar newvar in
bind Alias newvar arg (body newarg)
let make_const i = Lconst (Const_base (Const_int i))
let make_isout h arg = Lprim (Pisout, [h ; arg])
let make_isin h arg = Lprim (Pnot,[make_isout h arg])
let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none)
let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none)
let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
let make_switch arg cases acts =
let l = ref [] in
@ -2218,7 +2225,7 @@ let mk_failaction_pos partial seen ctx defs =
fail,[],jumps
end
let combine_constant arg cst partial ctx def
let combine_constant loc arg cst partial ctx def
(const_lambda_list, total, _pats) =
let fail, local_jumps =
mk_failaction_neg partial ctx def in
@ -2248,24 +2255,24 @@ let combine_constant arg cst partial ctx def
| _ -> assert false)
const_lambda_list in
let hs,sw,fail = share_actions_tree sw fail in
hs (Lstringswitch (arg,sw,fail))
hs (Lstringswitch (arg,sw,fail,loc))
| Const_float _ ->
make_test_sequence
make_test_sequence loc
fail
(Pfloatcomp Cneq) (Pfloatcomp Clt)
arg const_lambda_list
| Const_int32 _ ->
make_test_sequence
make_test_sequence loc
fail
(Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt))
arg const_lambda_list
| Const_int64 _ ->
make_test_sequence
make_test_sequence loc
fail
(Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt))
arg const_lambda_list
| Const_nativeint _ ->
make_test_sequence
make_test_sequence loc
fail
(Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt))
arg const_lambda_list
@ -2298,7 +2305,7 @@ let split_extension_cases tag_lambda_list =
split_rec tag_lambda_list
let combine_constructor arg ex_pat cstr partial ctx def
let combine_constructor loc arg ex_pat cstr partial ctx def
(tag_lambda_list, total1, pats) =
if cstr.cstr_consts < 0 then begin
(* Special cases for extensions *)
@ -2325,17 +2332,17 @@ let combine_constructor arg ex_pat cstr partial ctx def
(fun (path, act) rem ->
Lifthenelse(Lprim(Pintcomp Ceq,
[Lvar tag;
transl_path ex_pat.pat_env path]),
transl_path ex_pat.pat_env path], loc),
act, rem))
nonconsts
default
in
Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg]), tests)
Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg], loc), tests)
in
List.fold_right
(fun (path, act) rem ->
Lifthenelse(Lprim(Pintcomp Ceq,
[arg; transl_path ex_pat.pat_env path]),
[arg; transl_path ex_pat.pat_env path], loc),
act, rem))
consts
nonconst_lambda
@ -2379,7 +2386,7 @@ let combine_constructor arg ex_pat cstr partial ctx def
match act0 with
| Some act ->
Lifthenelse
(Lprim (Pisint, [arg]),
(Lprim (Pisint, [arg], loc),
call_switcher
fail_opt arg
0 (n-1) consts,
@ -2405,13 +2412,13 @@ let call_switcher_variant_constant fail arg int_lambda_list =
call_switcher fail arg min_int max_int int_lambda_list
let call_switcher_variant_constr fail arg int_lambda_list =
let call_switcher_variant_constr loc fail arg int_lambda_list =
let v = Ident.create "variant" in
Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg]),
Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc),
call_switcher
fail (Lvar v) min_int max_int int_lambda_list)
let combine_variant row arg partial ctx def (tag_lambda_list, total1, _pats) =
let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats) =
let row = Btype.row_repr row in
let num_constr = ref 0 in
if row.row_closed then
@ -2424,7 +2431,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, _pats) =
else
num_constr := max_int;
let test_int_or_block arg if_int if_block =
Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in
Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in
let sig_complete = List.length tag_lambda_list = !num_constr
and one_action = same_actions tag_lambda_list in
let fail, local_jumps =
@ -2444,7 +2451,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, _pats) =
| (_, []) -> (* One can compare integers and pointers *)
make_test_sequence_variant_constant fail arg consts
| ([], _) ->
let lam = call_switcher_variant_constr
let lam = call_switcher_variant_constr loc
fail arg nonconsts in
(* One must not dereference integers *)
begin match fail with
@ -2456,14 +2463,14 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, _pats) =
call_switcher_variant_constant
fail arg consts
and lam_nonconst =
call_switcher_variant_constr
call_switcher_variant_constr loc
fail arg nonconsts in
test_int_or_block arg lam_const lam_nonconst
in
lambda1, jumps_union local_jumps total1
let combine_array arg kind partial ctx def
let combine_array loc arg kind partial ctx def
(len_lambda_list, total1, _pats) =
let fail, local_jumps = mk_failaction_neg partial ctx def in
let lambda1 =
@ -2473,7 +2480,7 @@ let combine_array arg kind partial ctx def
fail (Lvar newvar)
0 max_int len_lambda_list in
bind
Alias newvar (Lprim(Parraylength kind, [arg])) switch in
Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in
lambda1, jumps_union local_jumps total1
(* Insertion of debugging events *)
@ -2581,7 +2588,7 @@ let rec approx_present v = function
| Lconst _ -> false
| Lstaticraise (_,args) ->
List.exists (fun lam -> approx_present v lam) args
| Lprim (_,args) ->
| Lprim (_,args,_) ->
List.exists (fun lam -> approx_present v lam) args
| Llet (Alias, _k, _, l1, l2) ->
approx_present v l1 || approx_present v l2
@ -2744,17 +2751,18 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
compile_test
(compile_match repr partial) partial
divide_constant
(combine_constant arg cst partial)
(combine_constant pat.pat_loc arg cst partial)
ctx pm
| Tpat_construct (_, cstr, _) ->
compile_test
(compile_match repr partial) partial
divide_constructor (combine_constructor arg pat cstr partial)
divide_constructor
(combine_constructor pat.pat_loc arg pat cstr partial)
ctx pm
| Tpat_array _ ->
let kind = Typeopt.array_pattern_kind pat in
compile_test (compile_match repr partial) partial
(divide_array kind) (combine_array arg kind partial)
(divide_array kind) (combine_array pat.pat_loc arg kind partial)
ctx pm
| Tpat_lazy _ ->
compile_no_test
@ -2763,7 +2771,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
| Tpat_variant(_, _, row) ->
compile_test (compile_match repr partial) partial
(divide_variant !row)
(combine_variant !row arg partial)
(combine_variant pat.pat_loc !row arg partial)
ctx pm
| _ -> assert false
end
@ -2912,7 +2920,7 @@ let partial_function loc () =
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
Const_base(Const_int line);
Const_base(Const_int char)]))])])
Const_base(Const_int char)]))], loc)], loc)
let for_function loc repr param pat_act_list partial =
compile_matching repr (partial_function loc) param pat_act_list partial
@ -2920,7 +2928,7 @@ let for_function loc repr param pat_act_list partial =
(* In the following two cases, exhaustiveness info is not available! *)
let for_trywith param pat_act_list =
compile_matching None
(fun () -> Lprim(Praise Raise_reraise, [param]))
(fun () -> Lprim(Praise Raise_reraise, [param], Location.none))
param pat_act_list Partial
let simple_for_let loc param pat body =
@ -2985,7 +2993,7 @@ let rec map_return f = function
| Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2)
| Lstaticcatch (l1, b, l2) ->
Lstaticcatch (map_return f l1, b, map_return f l2)
| Lstaticraise _ | Lprim(Praise _, _) as l -> l
| Lstaticraise _ | Lprim(Praise _, _, _) as l -> l
| l -> f l
(* The 'opt' reference indicates if the optimization is worthy.
@ -3005,7 +3013,7 @@ let rec map_return f = function
let assign_pat opt nraise catch_ids loc pat lam =
let rec collect acc pat lam = match pat.pat_desc, lam with
| Tpat_tuple patl, Lprim(Pmakeblock _, lams) ->
| Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) ->
opt := true;
List.fold_left2 collect acc patl lams
| Tpat_tuple patl, Lconst(Const_block(_, scl)) ->
@ -3147,12 +3155,12 @@ let do_for_multiple_match loc paraml pat_act_list partial =
let raise_num = next_raise_count () in
raise_num,
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
args = [Lprim(Pmakeblock(0, Immutable, None), paraml), Strict];
args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict];
default = [[[omega]],raise_num] }
| _ ->
-1,
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
args = [Lprim(Pmakeblock(0, Immutable, None), paraml), Strict];
args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict];
default = [] } in
try

2
bytecomp/matching.mli
View File

@ -41,6 +41,6 @@ val flatten_pattern: int -> pattern -> pattern list
(* Expand stringswitch to string test tree *)
val expand_stringswitch:
lambda -> (string * lambda) list -> lambda option -> lambda
Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda
val inline_lazy_force : lambda -> Location.t -> lambda

12
bytecomp/printlambda.ml
View File

@ -129,8 +129,8 @@ let block_shape ppf shape = match shape with
let primitive ppf = function
| Pidentity -> fprintf ppf "id"
| Pignore -> fprintf ppf "ignore"
| Prevapply _ -> fprintf ppf "revapply"
| Pdirapply _ -> fprintf ppf "dirapply"
| Prevapply -> fprintf ppf "revapply"
| Pdirapply -> fprintf ppf "dirapply"
| Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind)
| Pgetglobal id -> fprintf ppf "global %a" Ident.print id
| Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
@ -298,8 +298,8 @@ let primitive ppf = function
let name_of_primitive = function
| Pidentity -> "Pidentity"
| Pignore -> "Pignore"
| Prevapply _ -> "Prevapply"
| Pdirapply _ -> "Pdirapply"
| Prevapply -> "Prevapply"
| Pdirapply -> "Pdirapply"
| Ploc _ -> "Ploc"
| Pgetglobal _ -> "Pgetglobal"
| Psetglobal _ -> "Psetglobal"
@ -473,7 +473,7 @@ let rec lam ppf = function
id_arg_list in
fprintf ppf
"@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
| Lprim(prim, largs) ->
| Lprim(prim, largs, _) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs
@ -500,7 +500,7 @@ let rec lam ppf = function
"@[<1>(%s %a@ @[<v 0>%a@])@]"
(match sw.sw_failaction with None -> "switch*" | _ -> "switch")
lam larg switch sw
| Lstringswitch(arg, cases, default) ->
| Lstringswitch(arg, cases, default, _) ->
let switch ppf cases =
let spc = ref false in
List.iter

108
bytecomp/simplif.ml
View File

@ -39,14 +39,14 @@ let rec eliminate_ref id = function
| Lletrec(idel, e2) ->
Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
eliminate_ref id e2)
| Lprim(Pfield 0, [Lvar v]) when Ident.same v id ->
| Lprim(Pfield 0, [Lvar v], _) when Ident.same v id ->
Lvar id
| Lprim(Psetfield(0, _, _), [Lvar v; e]) when Ident.same v id ->
| Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id ->
Lassign(id, eliminate_ref id e)
| Lprim(Poffsetref delta, [Lvar v]) when Ident.same v id ->
Lassign(id, Lprim(Poffsetint delta, [Lvar id]))
| Lprim(p, el) ->
Lprim(p, List.map (eliminate_ref id) el)
| Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id ->
Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc))
| Lprim(p, el, loc) ->
Lprim(p, List.map (eliminate_ref id) el, loc)
| Lswitch(e, sw) ->
Lswitch(eliminate_ref id e,
{sw_numconsts = sw.sw_numconsts;
@ -57,11 +57,11 @@ let rec eliminate_ref id = function
List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks;
sw_failaction =
Misc.may_map (eliminate_ref id) sw.sw_failaction; })
| Lstringswitch(e, sw, default) ->
| Lstringswitch(e, sw, default, loc) ->
Lstringswitch
(eliminate_ref id e,
List.map (fun (s, e) -> (s, eliminate_ref id e)) sw,
Misc.may_map (eliminate_ref id) default)
Misc.may_map (eliminate_ref id) default, loc)
| Lstaticraise (i,args) ->
Lstaticraise (i,List.map (eliminate_ref id) args)
| Lstaticcatch(e1, i, e2) ->
@ -117,13 +117,13 @@ let simplify_exits lam =
| Lletrec(bindings, body) ->
List.iter (fun (_v, l) -> count l) bindings;
count body
| Lprim(_p, ll) -> List.iter count ll
| Lprim(_p, ll, _) -> List.iter count ll
| Lswitch(l, sw) ->
count_default sw ;
count l;
List.iter (fun (_, l) -> count l) sw.sw_consts;
List.iter (fun (_, l) -> count l) sw.sw_blocks
| Lstringswitch(l, sw, d) ->
| Lstringswitch(l, sw, d, _) ->
count l;
List.iter (fun (_, l) -> count l) sw;
begin match d with
@ -200,37 +200,37 @@ let simplify_exits lam =
| Lapply ap ->
Lapply{ap with ap_func = simplif ap.ap_func;
ap_args = List.map simplif ap.ap_args}
| Lfunction{kind; params; body = l; attr} ->
Lfunction{kind; params; body = simplif l; attr}
| Lfunction{kind; params; body = l; attr; loc} ->
Lfunction{kind; params; body = simplif l; attr; loc}
| Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2)
| Lletrec(bindings, body) ->
Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
| Lprim(p, ll) -> begin
| Lprim(p, ll, loc) -> begin
let ll = List.map simplif ll in
match p, ll with
(* Simplify %revapply, for n-ary functions with n > 1 *)
| Prevapply loc, [x; Lapply ap]
| Prevapply loc, [x; Levent (Lapply ap,_)] ->
| Prevapply, [x; Lapply ap]
| Prevapply, [x; Levent (Lapply ap,_)] ->
Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
| Prevapply loc, [x; f] -> Lapply {ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
| Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
(* Simplify %apply, for n-ary functions with n > 1 *)
| Pdirapply loc, [Lapply ap; x]
| Pdirapply loc, [Levent (Lapply ap,_); x] ->
| Pdirapply, [Lapply ap; x]
| Pdirapply, [Levent (Lapply ap,_); x] ->
Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
| Pdirapply loc, [f; x] -> Lapply {ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
| Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
| _ -> Lprim(p, ll)
| _ -> Lprim(p, ll, loc)
end
| Lswitch(l, sw) ->
let new_l = simplif l
@ -241,10 +241,10 @@ let simplify_exits lam =
(new_l,
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
sw_failaction = new_fail})
| Lstringswitch(l,sw,d) ->
| Lstringswitch(l,sw,d,loc) ->
Lstringswitch
(simplif l,List.map (fun (s,l) -> s,simplif l) sw,
Misc.may_map simplif d)
Misc.may_map simplif d,loc)
| Lstaticraise (i,[]) as l ->
begin try
let _,handler = Hashtbl.find subst i in
@ -359,7 +359,7 @@ let simplify_lets lam =
when optimize && List.length params = List.length args ->
count bv (beta_reduce params body args)
| Lapply{ap_func = Lfunction{kind = Tupled; params; body};
ap_args = [Lprim(Pmakeblock _, args)]}
ap_args = [Lprim(Pmakeblock _, args, _)]}
when optimize && List.length params = List.length args ->
count bv (beta_reduce params body args)
| Lapply{ap_func = l1; ap_args = ll} ->
@ -378,13 +378,13 @@ let simplify_lets lam =
| Lletrec(bindings, body) ->
List.iter (fun (_v, l) -> count bv l) bindings;
count bv body
| Lprim(_p, ll) -> List.iter (count bv) ll
| Lprim(_p, ll, _) -> List.iter (count bv) ll
| Lswitch(l, sw) ->
count_default bv sw ;
count bv l;
List.iter (fun (_, l) -> count bv l) sw.sw_consts;
List.iter (fun (_, l) -> count bv l) sw.sw_blocks
| Lstringswitch(l, sw, d) ->
| Lstringswitch(l, sw, d, _) ->
count bv l ;
List.iter (fun (_, l) -> count bv l) sw ;
begin match d with
@ -452,24 +452,24 @@ let simplify_lets lam =
when optimize && List.length params = List.length args ->
simplif (beta_reduce params body args)
| Lapply{ap_func = Lfunction{kind = Tupled; params; body};
ap_args = [Lprim(Pmakeblock _, args)]}
ap_args = [Lprim(Pmakeblock _, args, _)]}
when optimize && List.length params = List.length args ->
simplif (beta_reduce params body args)
| Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func;
ap_args = List.map simplif ap.ap_args}
| Lfunction{kind; params; body = l; attr} ->
| Lfunction{kind; params; body = l; attr; loc} ->
begin match simplif l with
Lfunction{kind=Curried; params=params'; body; attr}
Lfunction{kind=Curried; params=params'; body; attr; loc}
when kind = Curried && optimize ->
Lfunction{kind; params = params @ params'; body; attr}
Lfunction{kind; params = params @ params'; body; attr; loc}
| body ->
Lfunction{kind; params; body; attr}
Lfunction{kind; params; body; attr; loc}
end
| Llet(_str, _k, v, Lvar w, l2) when optimize ->
Hashtbl.add subst v (simplif (Lvar w));
simplif l2
| Llet(Strict, kind, v,
Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit]), lbody)
Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody)
when optimize && Config.flambda = false ->
let slinit = simplif linit in
let slbody = simplif lbody in
@ -481,7 +481,7 @@ let simplify_lets lam =
in
mklet Variable kind v slinit (eliminate_ref v slbody)
with Real_reference ->
mklet Strict kind v (Lprim(prim, [slinit])) slbody
mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody
end
| Llet(Alias, kind, v, l1, l2) ->
begin match count_var v with
@ -497,7 +497,7 @@ let simplify_lets lam =
| Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2)
| Lletrec(bindings, body) ->
Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
| Lprim(p, ll) -> Lprim(p, List.map simplif ll)
| Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc)
| Lswitch(l, sw) ->
let new_l = simplif l
and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
@ -507,10 +507,10 @@ let simplify_lets lam =
(new_l,
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
sw_failaction = new_fail})
| Lstringswitch (l,sw,d) ->
| Lstringswitch (l,sw,d,loc) ->
Lstringswitch
(simplif l,List.map (fun (s,l) -> s,simplif l) sw,
Misc.may_map simplif d)
Misc.may_map simplif d,loc)
| Lstaticraise (i,ls) ->
Lstaticraise (i, List.map simplif ls)
| Lstaticcatch(l1, (i,args), l2) ->
@ -566,20 +566,20 @@ let rec emit_tail_infos is_tail lambda =
| Lletrec (bindings, body) ->
List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings;
emit_tail_infos is_tail body
| Lprim (Pidentity, [arg]) ->
| Lprim (Pidentity, [arg], _) ->
emit_tail_infos is_tail arg
| Lprim (Psequand, [arg1; arg2])
| Lprim (Psequor, [arg1; arg2]) ->
| Lprim (Psequand, [arg1; arg2], _)
| Lprim (Psequor, [arg1; arg2], _) ->
emit_tail_infos false arg1;
emit_tail_infos is_tail arg2
| Lprim (_, l) ->
| Lprim (_, l, _) ->
list_emit_tail_infos false l
| Lswitch (lam, sw) ->
emit_tail_infos false lam;
list_emit_tail_infos_fun snd is_tail sw.sw_consts;
list_emit_tail_infos_fun snd is_tail sw.sw_blocks;
Misc.may (emit_tail_infos is_tail) sw.sw_failaction
| Lstringswitch (lam, sw, d) ->
| Lstringswitch (lam, sw, d, _) ->
emit_tail_infos false lam;
List.iter
(fun (_,lam) -> emit_tail_infos is_tail lam)
@ -633,7 +633,7 @@ and list_emit_tail_infos is_tail =
function's body. *)
let split_default_wrapper ?(create_wrapper_body = fun lam -> lam)
fun_id kind params body attr =
fun_id kind params body attr loc =
let rec aux map = function
| Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
Ident.name optparam = "*opt*" && List.mem optparam params
@ -670,16 +670,16 @@ let split_default_wrapper ?(create_wrapper_body = fun lam -> lam)
in
let body = Lambda.subst_lambda subst body in
let inner_fun =
Lfunction { kind = Curried; params = new_ids; body; attr; }
Lfunction { kind = Curried; params = new_ids; body; attr; loc; }
in
(wrapper_body, (inner_id, inner_fun))
in
try
let wrapper_body, inner = aux [] body in
[(fun_id, Lfunction{kind; params; body = create_wrapper_body wrapper_body;
attr}); inner]
attr; loc}); inner]
with Exit ->
[(fun_id, Lfunction{kind; params; body; attr})]
[(fun_id, Lfunction{kind; params; body; attr; loc})]
(* The entry point:
simplification + emission of tailcall annotations, if needed. *)

1
bytecomp/simplif.mli
View File

@ -29,6 +29,7 @@ val split_default_wrapper
-> Ident.t list
-> lambda
-> function_attribute
-> Location.t
-> (Ident.t * lambda) list
(* To be filled by asmcomp/selectgen.ml *)

86
bytecomp/translclass.ml
View File

@ -29,12 +29,13 @@ exception Error of Location.t * error
let lfunction params body =
if params = [] then body else
match body with
| Lfunction {kind = Curried; params = params'; body = body'; attr} ->
Lfunction {kind = Curried; params = params @ params'; body = body'; attr}
| Lfunction {kind = Curried; params = params'; body = body'; attr; loc} ->
Lfunction {kind = Curried; params = params @ params'; body = body'; attr; loc}
| _ ->
Lfunction {kind = Curried; params;
body;
attr = default_function_attribute}
attr = default_function_attribute;
loc = Location.none}
let lapply ap =
match ap.ap_func with
@ -54,7 +55,7 @@ let mkappl (func, args) =
let lsequence l1 l2 =
if l2 = lambda_unit then l1 else Lsequence(l1, l2)
let lfield v i = Lprim(Pfield i, [Lvar v])
let lfield v i = Lprim(Pfield i, [Lvar v], Location.none)
let transl_label l = share (Const_immstring l)
@ -69,7 +70,7 @@ let set_inst_var obj id expr =
| Pointer -> Paddrarray
| Immediate -> Pintarray
in
Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr])
Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr], Location.none)
let transl_val tbl create name =
mkappl (oo_prim (if create then "new_variable" else "get_variable"),
@ -131,7 +132,10 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
let envs, inh_init = inh_init in
let env =
match envs with None -> []
| Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
| Some envs ->
[Lprim(Pfield (List.length inh_init + 1),
[Lvar envs],
Location.none)]
in
((envs, (obj_init, normalize_cl_path cl path)
::inh_init),
@ -175,6 +179,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
let param = name_pattern "param" pat in
Lfunction {kind = Curried; params = param::params;
attr = default_function_attribute;
loc = pat.pat_loc;
body = Matching.for_function
pat.pat_loc None (Lvar param) [pat, rem] partial}
in
@ -245,7 +250,7 @@ let output_methods tbl methods lam =
| _ ->
lsequence (mkappl(oo_prim "set_methods",
[Lvar tbl; Lprim(Pmakeblock(0,Immutable,None),
methods)]))
methods, Location.none)]))
lam
let rec ignore_cstrs cl =
@ -269,8 +274,9 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in
(inh_init,
Llet (Strict, Pgenval, obj_init,
mkappl(Lprim(Pfield 1, [lpath]), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath])] else []),
mkappl(Lprim(Pfield 1, [lpath], Location.none), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath], Location.none)]
else []),
bind_super cla super cl_init))
| _ ->
assert false
@ -425,6 +431,7 @@ let rec transl_class_rebind obj_init cl vf =
let param = name_pattern "param" pat in
Lfunction {kind = Curried; params = param::params;
attr = default_function_attribute;
loc = pat.pat_loc;
body = Matching.for_function
pat.pat_loc None (Lvar param) [pat, rem] partial}
in
@ -494,7 +501,8 @@ let transl_class_rebind ids cl vf =
(mkappl(Lvar new_init,
[mkappl(Lvar env_init, [Lvar envs])]))));
lfield cla 2;
lfield cla 3])))
lfield cla 3],
Location.none)))
with Exit ->
lambda_unit
@ -503,9 +511,9 @@ let transl_class_rebind ids cl vf =
let rec module_path = function
Lvar id ->
let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z'
| Lprim(Pfield _, [p]) -> module_path p
| Lprim(Pgetglobal _, []) -> true
| _ -> false
| Lprim(Pfield _, [p], _) -> module_path p
| Lprim(Pgetglobal _, [], _) -> true
| _ -> false
let const_path local = function
Lvar id -> not (List.mem id local)
@ -520,9 +528,9 @@ let rec builtin_meths self env env2 body =
let conv = function
(* Lvar s when List.mem s self -> "_self", [] *)
| p when const_path p -> "const", [p]
| Lprim(Parrayrefu _, [Lvar s; Lvar n]) when List.mem s self ->
| Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self ->
"var", [Lvar n]
| Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
| Lprim(Pfield n, [Lvar e], _) when Ident.same e env ->
"env", [Lvar env2; Lconst(Const_pointer n)]
| Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
"meth", [met]
@ -552,7 +560,7 @@ let rec builtin_meths self env env2 body =
("send_"^s, met :: args)
| Lfunction {kind = Curried; params = [x]; body} ->
let rec enter self = function
| Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
| Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _)
when Ident.same x x' && List.mem s self ->
("set_var", [Lvar n])
| Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
@ -676,7 +684,9 @@ let transl_class ids cl_id pub_meths cl vflag =
(if not (IdentSet.mem env (free_variables body')) then body' else
Llet(Alias, Pgenval, env,
Lprim(Parrayrefu Paddrarray,
[Lvar self; Lvar env2]), body'))]
[Lvar self; Lvar env2],
Location.none),
body'))]
end
| _ -> assert false
in
@ -685,7 +695,8 @@ let transl_class ids cl_id pub_meths cl vflag =
let copy_env self =
if top then lambda_unit else
Lifused(env2, Lprim(Parraysetu Paddrarray,
[Lvar self; Lvar env2; Lvar env1']))
[Lvar self; Lvar env2; Lvar env1'],
Location.none))
and subst_env envs l lam =
if top then lam else
(* must be called only once! *)
@ -735,6 +746,7 @@ let transl_class ids cl_id pub_meths cl vflag =
and lclass lam =
let cl_init = llets (Lfunction{kind = Curried;
attr = default_function_attribute;
loc = Location.none;
params = [cla]; body = cl_init}) in
Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init))
and lbody fv =
@ -749,13 +761,16 @@ let transl_class ids cl_id pub_meths cl vflag =
mkappl (oo_prim "init_class", [Lvar table]),
Lprim(Pmakeblock(0, Immutable, None),
[mkappl (Lvar env_init, [lambda_unit]);
Lvar class_init; Lvar env_init; lambda_unit]))))
Lvar class_init; Lvar env_init; lambda_unit],
Location.none))))
and lbody_virt lenvs =
Lprim(Pmakeblock(0, Immutable, None),
[lambda_unit; Lfunction{kind = Curried;
attr = default_function_attribute;
loc = Location.none;
params = [cla]; body = cl_init};
lambda_unit; lenvs])
lambda_unit; lenvs],
Location.none)
in
(* Still easy: a class defined at toplevel *)
if top && concrete then lclass lbody else
@ -772,18 +787,22 @@ let transl_class ids cl_id pub_meths cl vflag =
let menv =
if !new_ids_meths = [] then lambda_unit else
Lprim(Pmakeblock(0, Immutable, None),
List.map (fun id -> Lvar id) !new_ids_meths) in
List.map (fun id -> Lvar id) !new_ids_meths,
Location.none) in
if !new_ids_init = [] then menv else
Lprim(Pmakeblock(0, Immutable, None),
menv :: List.map (fun id -> Lvar id) !new_ids_init)
menv :: List.map (fun id -> Lvar id) !new_ids_init,
Location.none)
and linh_envs =
List.map (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p]))
List.map
(fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p], Location.none))
(List.rev inh_init)
in
let make_envs lam =
Llet(StrictOpt, Pgenval, envs,
(if linh_envs = [] then lenv else
Lprim(Pmakeblock(0, Immutable, None), lenv :: linh_envs)),
Lprim(Pmakeblock(0, Immutable, None),
lenv :: linh_envs, Location.none)),
lam)
and def_ids cla lam =
Llet(StrictOpt, Pgenval, env2,
@ -792,23 +811,28 @@ let transl_class ids cl_id pub_meths cl vflag =
in
let inh_paths =
List.filter
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init
in
let inh_keys =
List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in
List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p], Location.none))
inh_paths
in
let lclass lam =
Llet(Strict, Pgenval, class_init,
Lfunction{kind = Curried; params = [cla];
attr = default_function_attribute;
loc = Location.none;
body = def_ids cla cl_init}, lam)
and lcache lam =
if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else
Llet(Strict, Pgenval, cached,
mkappl (oo_prim "lookup_tables",
[Lvar tables; Lprim(Pmakeblock(0, Immutable, None),
inh_keys)]),
inh_keys, Location.none)]),
lam)
and lset cached i lam =
Lprim(Psetfield(i, Pointer, Assignment), [Lvar cached; lam])
Lprim(Psetfield(i, Pointer, Assignment),
[Lvar cached; lam], Location.none)
in
let ldirect () =
ltable cla
@ -817,6 +841,7 @@ let transl_class ids cl_id pub_meths cl vflag =
lset cached 0 (Lvar env_init))))
and lclass_virt () =
lset cached 0 (Lfunction{kind = Curried; attr = default_function_attribute;
loc = Location.none;
params = [cla]; body = def_ids cla cl_init})
in
llets (
@ -832,12 +857,13 @@ let transl_class ids cl_id pub_meths cl vflag =
make_envs (
if ids = [] then mkappl (lfield cached 0, [lenvs]) else
Lprim(Pmakeblock(0, Immutable, None),
if concrete then
(if concrete then
[mkappl (lfield cached 0, [lenvs]);
lfield cached 1;
lfield cached 0;
lenvs]
else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
else [lambda_unit; lfield cached 0; lambda_unit; lenvs]),
Location.none
)))))
(* Wrapper for class compilation *)

153
bytecomp/translcore.ml
View File

@ -56,13 +56,15 @@ let transl_extension_constructor env path ext =
| Some p, None -> Path.name p
| Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
in
let loc = ext.ext_loc in
match ext.ext_kind with
Text_decl _ ->
Lprim (Pmakeblock (Obj.object_tag, Immutable, None),
[Lconst (Const_base (Const_string (name, None)));
Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))])])
Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)],
loc)
| Text_rebind(path, _lid) ->
transl_path ~loc:ext.ext_loc env path
transl_path ~loc env path
(* Translation of primitives *)
@ -149,6 +151,13 @@ let comparisons_table = create_hashtable 11 [
let primitives_table = create_hashtable 57 [
"%identity", Pidentity;
"%ignore", Pignore;
"%revapply", Prevapply;
"%apply", Pdirapply;
"%loc_LOC", Ploc Loc_LOC;
"%loc_FILE", Ploc Loc_FILE;
"%loc_LINE", Ploc Loc_LINE;
"%loc_POS", Ploc Loc_POS;
"%loc_MODULE", Ploc Loc_MODULE;
"%field0", Pfield 0;
"%field1", Pfield 1;
"%setfield0", Psetfield(0, Pointer, Assignment);
@ -326,16 +335,8 @@ let primitives_table = create_hashtable 57 [
"%opaque", Popaque;
]
let find_primitive loc prim_name =
match prim_name with
"%revapply" -> Prevapply loc
| "%apply" -> Pdirapply loc
| "%loc_LOC" -> Ploc Loc_LOC
| "%loc_FILE" -> Ploc Loc_FILE
| "%loc_LINE" -> Ploc Loc_LINE
| "%loc_POS" -> Ploc Loc_POS
| "%loc_MODULE" -> Ploc Loc_MODULE
| name -> Hashtbl.find primitives_table name
let find_primitive prim_name =
Hashtbl.find primitives_table prim_name
let specialize_comparison table env ty =
let (gencomp, intcomp, floatcomp, stringcomp,
@ -354,7 +355,7 @@ let specialize_comparison table env ty =
(* Specialize a primitive from available type information,
raise Not_found if primitive is unknown *)
let specialize_primitive loc p env ty ~has_constant_constructor =
let specialize_primitive p env ty ~has_constant_constructor =
try
let table = Hashtbl.find comparisons_table p.prim_name in
let (gencomp, intcomp, _, _, _, _, _, simplify_constant_constructor) =
@ -366,7 +367,7 @@ let specialize_primitive loc p env ty ~has_constant_constructor =
| Some (lhs,_rhs) -> specialize_comparison table env lhs
| None -> gencomp
with Not_found ->
let p = find_primitive loc p.prim_name in
let p = find_primitive p.prim_name in
(* Try strength reduction based on the type of the argument *)
let params = match is_function_type env ty with
| None -> []
@ -409,7 +410,7 @@ let add_used_primitive loc env path =
let transl_primitive loc p env ty path =
let prim =
try specialize_primitive loc p env ty ~has_constant_constructor:false
try specialize_primitive p env ty ~has_constant_constructor:false
with Not_found ->
add_used_primitive loc env path;
Pccall p
@ -419,6 +420,7 @@ let transl_primitive loc p env ty path =
let parm = Ident.create "prim" in
Lfunction{kind = Curried; params = [parm];
body = Matching.inline_lazy_force (Lvar parm) Location.none;
loc = loc;
attr = default_function_attribute }
| Ploc kind ->
let lam = lam_of_loc kind loc in
@ -428,8 +430,9 @@ let transl_primitive loc p env ty path =
let param = Ident.create "prim" in
Lfunction{kind = Curried; params = [param];
attr = default_function_attribute;
loc = loc;
body = Lprim(Pmakeblock(0, Immutable, None),
[lam; Lvar param])}
[lam; Lvar param], loc)}
| _ -> assert false
end
| _ ->
@ -438,7 +441,8 @@ let transl_primitive loc p env ty path =
let params = make_params p.prim_arity in
Lfunction{ kind = Curried; params;
attr = default_function_attribute;
body = Lprim(prim, List.map (fun id -> Lvar id) params) }
loc = loc;
body = Lprim(prim, List.map (fun id -> Lvar id) params, loc) }
let transl_primitive_application loc prim env ty path args =
let prim_name = prim.prim_name in
@ -450,7 +454,7 @@ let transl_primitive_application loc prim env ty path args =
| [{exp_desc = Texp_variant(_, None)}; _] -> true
| _ -> false
in
specialize_primitive loc prim env ty ~has_constant_constructor
specialize_primitive prim env ty ~has_constant_constructor
with Not_found ->
if String.length prim_name > 0 && prim_name.[0] = '%' then
raise(Error(loc, Unknown_builtin_primitive prim_name));
@ -471,8 +475,8 @@ let check_recursive_lambda idlist lam =
let idlist' = add_letrec bindings idlist in
List.for_all (fun (_id, arg) -> check idlist' arg) bindings &&
check_top idlist' body
| Lprim (Pmakearray (Pgenarray, _), _) -> false
| Lprim (Pmakearray (Pfloatarray, _), args) ->
| Lprim (Pmakearray (Pgenarray, _), _, _) -> false
| Lprim (Pmakearray (Pfloatarray, _), args, _) ->
List.for_all (check idlist) args
| Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2
| Levent (lam, _) -> check_top idlist lam
@ -489,10 +493,10 @@ let check_recursive_lambda idlist lam =
let idlist' = add_letrec bindings idlist in
List.for_all (fun (_id, arg) -> check idlist' arg) bindings &&
check idlist' body
| Lprim(Pmakeblock _, args) ->
| Lprim(Pmakeblock _, args, _) ->
List.for_all (check idlist) args
| Lprim (Pmakearray (Pfloatarray, _), _) -> false
| Lprim (Pmakearray _, args) ->
| Lprim (Pmakearray (Pfloatarray, _), _, _) -> false
| Lprim (Pmakearray _, args, _) ->
List.for_all (check idlist) args
| Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2
| Levent (lam, _) -> check idlist lam
@ -513,13 +517,13 @@ let check_recursive_lambda idlist lam =
(* reverse-engineering the code generated by transl_record case 2 *)
(* If you change this, you probably need to change Bytegen.size_of_lambda. *)
and check_recursive_recordwith idlist = function
| Llet (Strict, _k, id1, Lprim (Pduprecord _, [e1]), body) ->
| Llet (Strict, _k, id1, Lprim (Pduprecord _, [e1], _), body) ->
check_top idlist e1
&& check_recordwith_updates idlist id1 body
| _ -> false
and check_recordwith_updates idlist id1 = function
| Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont)
| Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1], _), cont)
-> id2 = id1 && check idlist e1
&& check_recordwith_updates idlist id1 cont
| Lvar id2 -> id2 = id1
@ -615,7 +619,7 @@ let rec push_defaults loc bindings cases partial =
let event_before exp lam = match lam with
| Lstaticraise (_,_) -> lam
| _ ->
if !Clflags.debug
if !Clflags.debug && not !Clflags.native_code
then Levent(lam, {lev_loc = exp.exp_loc;
lev_kind = Lev_before;
lev_repr = None;
@ -623,7 +627,7 @@ let event_before exp lam = match lam with
else lam
let event_after exp lam =
if !Clflags.debug
if !Clflags.debug && not !Clflags.native_code
then Levent(lam, {lev_loc = exp.exp_loc;
lev_kind = Lev_after exp.exp_type;
lev_repr = None;
@ -631,7 +635,7 @@ let event_after exp lam =
else lam
let event_function exp lam =
if !Clflags.debug then
if !Clflags.debug && not !Clflags.native_code then
let repr = Some (ref 0) in
let (info, body) = lam repr in
(info,
@ -646,8 +650,8 @@ let primitive_is_ccall = function
(* Determine if a primitive is a Pccall or will be turned later into
a C function call that may raise an exception *)
| Pccall _ | Pstringrefs | Pstringsets | Parrayrefs _ | Parraysets _ |
Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply _ |
Prevapply _ -> true
Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply |
Prevapply -> true
| _ -> false
(* Assertions *)
@ -661,7 +665,7 @@ let assert_failed exp =
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
Const_base(Const_int line);
Const_base(Const_int char)]))]))])
Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc)
;;
let rec cut n l =
@ -693,12 +697,14 @@ and transl_exp0 e =
let obj = Ident.create "obj" and meth = Ident.create "meth" in
Lfunction{kind = Curried; params = [obj; meth];
attr = default_function_attribute;
loc = e.exp_loc;
body = Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)}
else if p.prim_name = "%sendcache" then
let obj = Ident.create "obj" and meth = Ident.create "meth" in
let cache = Ident.create "cache" and pos = Ident.create "pos" in
Lfunction{kind = Curried; params = [obj; meth; cache; pos];
attr = default_function_attribute;
loc = e.exp_loc;
body = Lsend(Cached, Lvar meth, Lvar obj,
[Lvar cache; Lvar pos], e.exp_loc)}
else
@ -725,7 +731,8 @@ and transl_exp0 e =
specialise = Translattribute.get_specialise_attribute e.exp_attributes;
}
in
Lfunction{kind; params; body; attr}
let loc = e.exp_loc in
Lfunction{kind; params; body; attr; loc}
| Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
exp_type = prim_type } as funct, oargs)
when List.length oargs >= p.prim_arity
@ -778,19 +785,19 @@ and transl_exp0 e =
| _ ->
k
in
wrap0 (Lprim(Praise k, [event_after arg1 targ]))
wrap0 (Lprim(Praise k, [event_after arg1 targ], e.exp_loc))
| (Ploc kind, []) ->
lam_of_loc kind e.exp_loc
| (Ploc kind, [arg1]) ->
let lam = lam_of_loc kind arg1.exp_loc in
Lprim(Pmakeblock(0, Immutable, None), lam :: argl)
Lprim(Pmakeblock(0, Immutable, None), lam :: argl, e.exp_loc)
| (Ploc _, _) -> assert false
| (_, _) ->
begin match (prim, argl) with
| (Plazyforce, [a]) ->
wrap (Matching.inline_lazy_force a e.exp_loc)
| (Plazyforce, _) -> assert false
|_ -> let p = Lprim(prim, argl) in
|_ -> let p = Lprim(prim, argl, e.exp_loc) in
if primitive_is_ccall prim then wrap p else wrap0 p
end
end
@ -819,7 +826,7 @@ and transl_exp0 e =
begin try
Lconst(Const_block(0, List.map extract_constant ll))
with Not_constant ->
Lprim(Pmakeblock(0, Immutable, Some shape), ll)
Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc)
end
| Texp_construct(_, cstr, args) ->
let ll, shape = transl_list_with_shape args in
@ -833,14 +840,14 @@ and transl_exp0 e =
begin try
Lconst(Const_block(n, List.map extract_constant ll))
with Not_constant ->
Lprim(Pmakeblock(n, Immutable, Some shape), ll)
Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc)
end
| Cstr_extension(path, is_const) ->
if is_const then
transl_path e.exp_env path
else
Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)),
transl_path e.exp_env path :: ll)
transl_path e.exp_env path :: ll, e.exp_loc)
end
| Texp_extension_constructor (_, path) ->
transl_path e.exp_env path
@ -855,10 +862,11 @@ and transl_exp0 e =
extract_constant lam]))
with Not_constant ->
Lprim(Pmakeblock(0, Immutable, None),
[Lconst(Const_base(Const_int tag)); lam])
[Lconst(Const_base(Const_int tag)); lam], e.exp_loc)
end
| Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
transl_record e.exp_env lbl1.lbl_all lbl1.lbl_repres lbl_expr_list
transl_record e.exp_loc e.exp_env
lbl1.lbl_all lbl1.lbl_repres lbl_expr_list
opt_init_expr
| Texp_record ([], _) ->
fatal_error "Translcore.transl_exp: bad Texp_record"
@ -869,7 +877,7 @@ and transl_exp0 e =
| Record_float -> Pfloatfield lbl.lbl_pos
| Record_extension -> Pfield (lbl.lbl_pos + 1)
in
Lprim(access, [transl_exp arg])
Lprim(access, [transl_exp arg], e.exp_loc)
| Texp_setfield(arg, _, lbl, newval) ->
let access =
match lbl.lbl_repres with
@ -880,7 +888,7 @@ and transl_exp0 e =
| Record_extension ->
Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)
in
Lprim(access, [transl_exp arg; transl_exp newval])
Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc)
| Texp_array expr_list ->
let kind = array_kind e in
let ll = transl_list expr_list in
@ -907,8 +915,10 @@ and transl_exp0 e =
where the array turned out to be inconstant).
When not [Pfloatarray], the exception propagates to the handler
below. *)
let imm_array = Lprim (Pmakearray (kind, Immutable), ll) in
Lprim (Pduparray (kind, Mutable), [imm_array])
let imm_array =
Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc)
in
Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc)
| cl ->
let imm_array =
match kind with
@ -919,10 +929,10 @@ and transl_exp0 e =
| Pgenarray ->
raise Not_constant (* can this really happen? *)
in
Lprim (Pduparray (kind, Mutable), [imm_array])
Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc)
end
with Not_constant ->
Lprim(Pmakearray (kind, Mutable), ll)
Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc)
end
| Texp_ifthenelse(cond, ifso, Some ifnot) ->
Lifthenelse(transl_exp cond,
@ -954,15 +964,15 @@ and transl_exp0 e =
| Texp_new (cl, {Location.loc=loc}, _) ->
Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]);
ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl], loc);
ap_args=[lambda_unit];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
| Texp_instvar(path_self, path, _) ->
Lprim(Parrayrefu Paddrarray,
[transl_normal_path path_self; transl_normal_path path])
[transl_normal_path path_self; transl_normal_path path], e.exp_loc)
| Texp_setinstvar(path_self, path, _, expr) ->
transl_setinstvar (transl_normal_path path_self) path expr
transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr
| Texp_override(path_self, modifs) ->
let cpy = Ident.create "copy" in
Llet(Strict, Pgenval, cpy,
@ -974,7 +984,8 @@ and transl_exp0 e =
ap_specialised=Default_specialise},
List.fold_right
(fun (path, _, expr) rem ->
Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
Lsequence(transl_setinstvar Location.none
(Lvar cpy) path expr, rem))
modifs
(Lvar cpy))
| Texp_letmodule(id, _, modl, body) ->
@ -1007,7 +1018,7 @@ and transl_exp0 e =
-> transl_exp e
| Texp_constant(Const_float _) ->
Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
[transl_exp e])
[transl_exp e], e.exp_loc)
| Texp_ident(_, _, _) -> (* according to the type *)
begin match e.exp_type.desc with
(* the following may represent a float/forward/lazy: need a
@ -1015,7 +1026,7 @@ and transl_exp0 e =
| Tvar _ | Tlink _ | Tsubst _ | Tunivar _
| Tpoly(_,_) | Tfield(_,_,_,_) ->
Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
[transl_exp e])
[transl_exp e], e.exp_loc)
(* the following cannot be represented as float/forward/lazy:
optimize *)
| Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil
@ -1038,14 +1049,15 @@ and transl_exp0 e =
then transl_exp e
else
Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
[transl_exp e])
[transl_exp e], e.exp_loc)
end
(* other cases compile to a lazy block holding a function *)
| _ ->
let fn = Lfunction {kind = Curried; params = [Ident.create "param"];
attr = default_function_attribute;
loc = e.exp_loc;
body = transl_exp e} in
Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn])
Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc)
end
| Texp_object (cs, meths) ->
let cty = cs.cstr_type in
@ -1147,14 +1159,14 @@ and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
and id_arg = Ident.create "param" in
let body =
match build_apply handle ((Lvar id_arg, optional)::args') l with
Lfunction{kind = Curried; params = ids; body = lam; attr} ->
Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr}
Lfunction{kind = Curried; params = ids; body = lam; attr; loc} ->
Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr; loc}
| Levent(Lfunction{kind = Curried; params = ids;
body = lam; attr}, _) ->
Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr}
body = lam; attr; loc}, _) ->
Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr; loc}
| lam ->
Lfunction{kind = Curried; params = [id_arg]; body = lam;
attr = default_function_attribute}
attr = default_function_attribute; loc = loc}
in
List.fold_left
(fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body))
@ -1242,15 +1254,15 @@ and transl_let rec_flag pat_expr_list body =
(id, lam) in
Lletrec(List.map2 transl_case pat_expr_list idlist, body)
and transl_setinstvar self var expr =
and transl_setinstvar loc self var expr =
let prim =
match maybe_pointer expr with
| Pointer -> Paddrarray
| Immediate -> Pintarray
in
Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr])
Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr], loc)
and transl_record env all_labels repres lbl_expr_list opt_init_expr =
and transl_record loc env all_labels repres lbl_expr_list opt_init_expr =
let size = Array.length all_labels in
(* Determine if there are "enough" fields (only relevant if this is a
functional-style record update *)
@ -1274,7 +1286,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
(* TODO recover the kind from the type of the original record *)
Pgenval
in
lv.(i) <- Lprim(access, [Lvar init_id]), field_kind
lv.(i) <- Lprim(access, [Lvar init_id], loc), field_kind
done
end;
List.iter
@ -1301,9 +1313,12 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
raise Not_constant
with Not_constant ->
match repres with
Record_regular -> Lprim(Pmakeblock(0, mut, Some shape), ll)
| Record_inlined tag -> Lprim(Pmakeblock(tag, mut, Some shape), ll)
| Record_float -> Lprim(Pmakearray (Pfloatarray, mut), ll)
Record_regular ->
Lprim(Pmakeblock(0, mut, Some shape), ll, loc)
| Record_inlined tag ->
Lprim(Pmakeblock(tag, mut, Some shape), ll, loc)
| Record_float ->
Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
| Record_extension ->
let path =
match all_labels.(0).lbl_res.desc with
@ -1311,7 +1326,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
| _ -> assert false
in
let slot = transl_path env path in
Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll)
Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc)
in
begin match opt_init_expr with
None -> lam
@ -1334,12 +1349,12 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
| Record_extension ->
Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment)
in
Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in
Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) in
begin match opt_init_expr with
None -> assert false
| Some init_expr ->
Llet(Strict, Pgenval, copy_id,
Lprim(Pduprecord (repres, size), [transl_exp init_expr]),
Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc),
List.fold_right update_field lbl_expr_list (Lvar copy_id))
end
end

215
bytecomp/translmod.ml
View File

@ -60,30 +60,32 @@ let transl_type_extension env rootpath tyext body =
(* Compile a coercion *)
let rec apply_coercion strict restr arg =
let rec apply_coercion loc strict restr arg =
match restr with
Tcoerce_none ->
arg
| Tcoerce_structure(pos_cc_list, id_pos_list) ->
name_lambda strict arg (fun id ->
let get_field pos = Lprim(Pfield pos,[Lvar id]) in
let get_field pos = Lprim(Pfield pos,[Lvar id], loc) in
let lam =
Lprim(Pmakeblock(0, Immutable, None),
List.map (apply_coercion_field get_field) pos_cc_list)
List.map (apply_coercion_field loc get_field) pos_cc_list,
loc)
in
wrap_id_pos_list id_pos_list get_field lam)
wrap_id_pos_list loc id_pos_list get_field lam)
| Tcoerce_functor(cc_arg, cc_res) ->
let param = Ident.create "funarg" in
name_lambda strict arg (fun id ->
Lfunction{kind = Curried; params = [param];
attr = { default_function_attribute with
is_a_functor = true };
loc = loc;
body = apply_coercion
Strict cc_res
loc Strict cc_res
(Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_loc=loc;
ap_func=Lvar id;
ap_args=[apply_coercion Alias cc_arg
ap_args=[apply_coercion loc Alias cc_arg
(Lvar param)];
ap_inlined=Default_inline;
ap_specialised=Default_specialise})})
@ -91,12 +93,12 @@ let rec apply_coercion strict restr arg =
transl_primitive pc_loc pc_desc pc_env pc_type None
| Tcoerce_alias (path, cc) ->
name_lambda strict arg
(fun _ -> apply_coercion Alias cc (transl_normal_path path))
(fun _ -> apply_coercion loc Alias cc (transl_normal_path path))
and apply_coercion_field get_field (pos, cc) =
apply_coercion Alias cc (get_field pos)
and apply_coercion_field loc get_field (pos, cc) =
apply_coercion loc Alias cc (get_field pos)
and wrap_id_pos_list id_pos_list get_field lam =
and wrap_id_pos_list loc id_pos_list get_field lam =
let fv = free_variables lam in
(*Format.eprintf "%a@." Printlambda.lambda lam;
IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv;
@ -106,7 +108,7 @@ and wrap_id_pos_list id_pos_list get_field lam =
if IdentSet.mem id' fv then
let id'' = Ident.create (Ident.name id') in
(Llet(Alias, Pgenval, id'',
apply_coercion Alias c (get_field pos),lam),
apply_coercion loc Alias c (get_field pos),lam),
Ident.add id' (Lvar id'') s)
else (lam,s))
(lam, Ident.empty) id_pos_list
@ -344,15 +346,16 @@ let transl_class_bindings cl_list =
let rec transl_module cc rootpath mexp =
List.iter (Translattribute.check_attribute_on_module mexp)
mexp.mod_attributes;
let loc = mexp.mod_loc in
match mexp.mod_type with
Mty_alias _ -> apply_coercion Alias cc lambda_unit
Mty_alias _ -> apply_coercion loc Alias cc lambda_unit
| _ ->
match mexp.mod_desc with
Tmod_ident (path,_) ->
apply_coercion Strict cc
(transl_path ~loc:mexp.mod_loc mexp.mod_env path)
apply_coercion loc Strict cc
(transl_path ~loc mexp.mod_env path)
| Tmod_structure str ->
fst (transl_struct [] cc rootpath str)
fst (transl_struct loc [] cc rootpath str)
| Tmod_functor(param, _, _, body) ->
let bodypath = functor_path rootpath param in
let inline_attribute =
@ -365,6 +368,7 @@ let rec transl_module cc rootpath mexp =
attr = { inline = inline_attribute;
specialise = Default_specialise;
is_a_functor = true };
loc = loc;
body = transl_module Tcoerce_none bodypath body}
| Tcoerce_functor(ccarg, ccres) ->
let param' = Ident.create "funarg" in
@ -372,8 +376,9 @@ let rec transl_module cc rootpath mexp =
attr = { inline = inline_attribute;
specialise = Default_specialise;
is_a_functor = true };
loc = loc;
body = Llet(Alias, Pgenval, param,
apply_coercion Alias ccarg
apply_coercion loc Alias ccarg
(Lvar param'),
transl_module ccres bodypath body)}
| _ ->
@ -384,9 +389,9 @@ let rec transl_module cc rootpath mexp =
Translattribute.get_and_remove_inlined_attribute_on_module funct
in
oo_wrap mexp.mod_env true
(apply_coercion Strict cc)
(apply_coercion loc Strict cc)
(Lapply{ap_should_be_tailcall=false;
ap_loc=mexp.mod_loc;
ap_loc=loc;
ap_func=transl_module Tcoerce_none None funct;
ap_args=[transl_module ccarg None arg];
ap_inlined=inlined_attribute;
@ -394,18 +399,18 @@ let rec transl_module cc rootpath mexp =
| Tmod_constraint(arg, _, _, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
apply_coercion Strict cc (Translcore.transl_exp arg)
apply_coercion loc Strict cc (Translcore.transl_exp arg)
and transl_struct fields cc rootpath str =
transl_structure fields cc rootpath str.str_final_env str.str_items
and transl_struct loc fields cc rootpath str =
transl_structure loc fields cc rootpath str.str_final_env str.str_items
and transl_structure fields cc rootpath final_env = function
and transl_structure loc fields cc rootpath final_env = function
[] ->
let body, size =
match cc with
Tcoerce_none ->
Lprim(Pmakeblock(0, Immutable, None),
List.map (fun id -> Lvar id) (List.rev fields)),
List.map (fun id -> Lvar id) (List.rev fields), loc),
List.length fields
| Tcoerce_structure(pos_cc_list, id_pos_list) ->
(* Do not ignore id_pos_list ! *)
@ -417,20 +422,20 @@ and transl_structure fields cc rootpath final_env = function
let get_field pos = Lvar v.(pos)
and ids = List.fold_right IdentSet.add fields IdentSet.empty in
let lam =
(Lprim(Pmakeblock(0, Immutable, None),
Lprim(Pmakeblock(0, Immutable, None),
List.map
(fun (pos, cc) ->
match cc with
Tcoerce_primitive p ->
transl_primitive p.pc_loc
p.pc_desc p.pc_env p.pc_type None
| _ -> apply_coercion Strict cc (get_field pos))
pos_cc_list))
| _ -> apply_coercion loc Strict cc (get_field pos))
pos_cc_list, loc)
and id_pos_list =
List.filter (fun (id,_,_) -> not (IdentSet.mem id ids))
id_pos_list
in
wrap_id_pos_list id_pos_list get_field lam,
wrap_id_pos_list loc id_pos_list get_field lam,
List.length pos_cc_list
| _ ->
fatal_error "Translmod.transl_structure"
@ -438,9 +443,9 @@ and transl_structure fields cc rootpath final_env = function
(* This debugging event provides information regarding the structure
items. It is ignored by the OCaml debugger but is used by
Js_of_ocaml to preserve variable names. *)
(if !Clflags.debug then
(if !Clflags.debug && not !Clflags.native_code then
Levent(body,
{lev_loc = Location.none;
{lev_loc = loc;
lev_kind = Lev_pseudo;
lev_repr = None;
lev_env = Env.summary final_env})
@ -450,22 +455,25 @@ and transl_structure fields cc rootpath final_env = function
| item :: rem ->
match item.str_desc with
| Tstr_eval (expr, _) ->
let body, size = transl_structure fields cc rootpath final_env rem in
let body, size =
transl_structure loc fields cc rootpath final_env rem
in
Lsequence(transl_exp expr, body), size
| Tstr_value(rec_flag, pat_expr_list) ->
let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
let body, size =
transl_structure ext_fields cc rootpath final_env rem in
transl_structure loc ext_fields cc rootpath final_env rem
in
transl_let rec_flag pat_expr_list body, size
| Tstr_primitive descr ->
record_primitive descr.val_val;
transl_structure fields cc rootpath final_env rem
transl_structure loc fields cc rootpath final_env rem
| Tstr_type _ ->
transl_structure fields cc rootpath final_env rem
transl_structure loc fields cc rootpath final_env rem
| Tstr_typext(tyext) ->
let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
let body, size =
transl_structure (List.rev_append ids fields)
transl_structure loc (List.rev_append ids fields)
cc rootpath final_env rem
in
transl_type_extension item.str_env rootpath tyext body, size
@ -473,13 +481,15 @@ and transl_structure fields cc rootpath final_env = function
let id = ext.ext_id in
let path = field_path rootpath id in
let body, size =
transl_structure (id :: fields) cc rootpath final_env rem in
transl_structure loc (id :: fields) cc rootpath final_env rem
in
Llet(Strict, Pgenval, id, transl_extension_constructor item.str_env path ext,
body), size
| Tstr_module mb ->
let id = mb.mb_id in
let body, size =
transl_structure (id :: fields) cc rootpath final_env rem in
transl_structure loc (id :: fields) cc rootpath final_env rem
in
let module_body =
transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
in
@ -495,7 +505,8 @@ and transl_structure fields cc rootpath final_env = function
List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields
in
let body, size =
transl_structure ext_fields cc rootpath final_env rem in
transl_structure loc ext_fields cc rootpath final_env rem
in
let lam =
compile_recmodule
(fun id modl ->
@ -507,7 +518,7 @@ and transl_structure fields cc rootpath final_env = function
| Tstr_class cl_list ->
let (ids, class_bindings) = transl_class_bindings cl_list in
let body, size =
transl_structure (List.rev_append ids fields)
transl_structure loc (List.rev_append ids fields)
cc rootpath final_env rem
in
Lletrec(class_bindings, body), size
@ -517,12 +528,14 @@ and transl_structure fields cc rootpath final_env = function
let mid = Ident.create "include" in
let rec rebind_idents pos newfields = function
[] ->
transl_structure newfields cc rootpath final_env rem
transl_structure loc newfields cc rootpath final_env rem
| id :: ids ->
let body, size =
rebind_idents (pos + 1) (id :: newfields) ids
in
Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid]), body), size
Llet(Alias, Pgenval, id,
Lprim(Pfield pos, [Lvar mid], incl.incl_loc), body),
size
in
let body, size = rebind_idents 0 fields ids in
Llet(pure_module modl, Pgenval, mid, transl_module Tcoerce_none None modl,
@ -532,7 +545,7 @@ and transl_structure fields cc rootpath final_env = function
| Tstr_open _
| Tstr_class_type _
| Tstr_attribute _ ->
transl_structure fields cc rootpath final_env rem
transl_structure loc fields cc rootpath final_env rem
and pure_module m =
match m.mod_desc with
@ -551,7 +564,7 @@ let scan_used_globals lam =
let rec scan lam =
Lambda.iter scan lam;
match lam with
Lprim ((Pgetglobal id | Psetglobal id), _) ->
Lprim ((Pgetglobal id | Psetglobal id), _, _) ->
globals := IdentSet.add id !globals
| _ -> ()
in
@ -576,7 +589,11 @@ let wrap_globals ~flambda body =
Env.reset_required_globals ();
Hashtbl.clear used_primitives;
IdentSet.fold
(fun id expr -> Lsequence(Lprim(Popaque, [Lprim(Pgetglobal id, [])]), expr))
(fun id expr ->
Lsequence(Lprim(Popaque,
[Lprim(Pgetglobal id, [], Location.none)],
Location.none),
expr))
required body
(* Location.prerr_warning loc
(Warnings.Nonrequired_global (Ident.name (Path.head path),
@ -592,7 +609,8 @@ let transl_implementation_flambda module_name (str, cc) =
let module_id = Ident.create_persistent module_name in
let body, size =
Translobj.transl_label_init
(fun () -> transl_struct [] cc (global_path module_id) str)
(fun () -> transl_struct Location.none [] cc
(global_path module_id) str)
in
(module_id, size), wrap_globals ~flambda:true body
@ -600,7 +618,7 @@ let transl_implementation module_name (str, cc) =
let (module_id, _size), module_initializer =
transl_implementation_flambda module_name (str, cc)
in
Lprim (Psetglobal module_id, [module_initializer])
Lprim (Psetglobal module_id, [module_initializer], Location.none)
(* Build the list of value identifiers defined by a toplevel structure
(excluding primitive declarations). *)
@ -703,7 +721,7 @@ let transl_store_subst = ref Ident.empty
let nat_toplevel_name id =
try match Ident.find_same id !transl_store_subst with
| Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])]) -> (glob,pos)
| Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos)
| _ -> raise Not_found
with Not_found ->
fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id)
@ -720,7 +738,9 @@ let transl_store_structure glob map prims str =
transl_store rootpath subst rem)
| Tstr_value(rec_flag, pat_expr_list) ->
let ids = let_bound_idents pat_expr_list in
let lam = transl_let rec_flag pat_expr_list (store_idents ids) in
let lam =
transl_let rec_flag pat_expr_list (store_idents Location.none ids)
in
Lsequence(subst_lambda subst lam,
transl_store rootpath (add_idents false ids subst) rem)
| Tstr_primitive descr ->
@ -734,7 +754,7 @@ let transl_store_structure glob map prims str =
in
let lam =
transl_type_extension item.str_env rootpath tyext
(store_idents ids)
(store_idents Location.none ids)
in
Lsequence(subst_lambda subst lam,
transl_store rootpath (add_idents false ids subst) rem)
@ -742,10 +762,10 @@ let transl_store_structure glob map prims str =
let id = ext.ext_id in
let path = field_path rootpath id in
let lam = transl_extension_constructor item.str_env path ext in
Lsequence(Llet(Strict, Pgenval, id,
subst_lambda subst lam, store_ident id),
Lsequence(Llet(Strict, Pgenval, id, subst_lambda subst lam,
store_ident ext.ext_loc id),
transl_store rootpath (add_ident false id subst) rem)
| Tstr_module{mb_id=id;
| Tstr_module{mb_id=id;mb_loc=loc;
mb_expr={mod_desc = Tmod_structure str} as mexp;
mb_attributes} ->
List.iter (Translattribute.check_attribute_on_module mexp)
@ -760,13 +780,13 @@ let transl_store_structure glob map prims str =
subst_lambda subst
(Lprim(Pmakeblock(0, Immutable, None),
List.map (fun id -> Lvar id)
(defined_idents str.str_items))),
Lsequence(store_ident id,
(defined_idents str.str_items), loc)),
Lsequence(store_ident loc id,
transl_store rootpath
(add_ident true id subst)
rem)))
| Tstr_module{
mb_id=id;
mb_id=id;mb_loc=loc;
mb_expr= {
mod_desc = Tmod_constraint (
{mod_desc = Tmod_structure str} as mexp, _, _,
@ -787,22 +807,22 @@ let transl_store_structure glob map prims str =
match cc with
| Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
transl_primitive pc_loc pc_desc pc_env pc_type None
| _ -> apply_coercion Strict cc (Lvar ids.(pos))
| _ -> apply_coercion loc Strict cc (Lvar ids.(pos))
in
Lsequence(lam,
Llet(Strict, Pgenval, id,
subst_lambda subst
(Lprim(Pmakeblock(0, Immutable, None),
List.map field map)),
Lsequence(store_ident id,
List.map field map, loc)),
Lsequence(store_ident loc id,
transl_store rootpath
(add_ident true id subst)
rem)))
| Tstr_module{mb_id=id; mb_expr=modl; mb_loc; mb_attributes} ->
| Tstr_module{mb_id=id; mb_expr=modl; mb_loc=loc; mb_attributes} ->
let lam =
Translattribute.add_inline_attribute
(transl_module Tcoerce_none (field_path rootpath id) modl)
mb_loc mb_attributes
loc mb_attributes
in
(* Careful: the module value stored in the global may be different
from the local module value, in case a coercion is applied.
@ -811,7 +831,7 @@ let transl_store_structure glob map prims str =
If not, we can use the value from the global
(add_ident true adds id -> Pgetglobal... to subst). *)
Llet(Strict, Pgenval, id, subst_lambda subst lam,
Lsequence(store_ident id,
Lsequence(store_ident loc id,
transl_store rootpath (add_ident true id subst) rem))
| Tstr_recmodule bindings ->
let ids = List.map (fun mb -> mb.mb_id) bindings in
@ -821,22 +841,27 @@ let transl_store_structure glob map prims str =
(transl_module Tcoerce_none
(field_path rootpath id) modl))
bindings
(Lsequence(store_idents ids,
(Lsequence(store_idents Location.none ids,
transl_store rootpath (add_idents true ids subst) rem))
| Tstr_class cl_list ->
let (ids, class_bindings) = transl_class_bindings cl_list in
let lam = Lletrec(class_bindings, store_idents ids) in
let lam =
Lletrec(class_bindings, store_idents Location.none ids)
in
Lsequence(subst_lambda subst lam,
transl_store rootpath (add_idents false ids subst) rem)
| Tstr_include incl ->
let ids = bound_value_identifiers incl.incl_type in
let modl = incl.incl_mod in
let mid = Ident.create "include" in
let loc = incl.incl_loc in
let rec store_idents pos = function
[] -> transl_store rootpath (add_idents true ids subst) rem
| id :: idl ->
Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid]),
Lsequence(store_ident id, store_idents (pos + 1) idl)) in
Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc),
Lsequence(store_ident loc id,
store_idents (pos + 1) idl))
in
Llet(Strict, Pgenval, mid,
subst_lambda subst (transl_module Tcoerce_none None modl),
store_idents 0 ids)
@ -846,24 +871,29 @@ let transl_store_structure glob map prims str =
| Tstr_attribute _ ->
transl_store rootpath subst rem
and store_ident id =
and store_ident loc id =
try
let (pos, cc) = Ident.find_same id map in
let init_val = apply_coercion Alias cc (Lvar id) in
let init_val = apply_coercion loc Alias cc (Lvar id) in
Lprim(Psetfield(pos, Pointer, Initialization),
[Lprim(Pgetglobal glob, []); init_val])
[Lprim(Pgetglobal glob, [], loc); init_val],
loc)
with Not_found ->
fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
and store_idents idlist =
make_sequence store_ident idlist
and store_idents loc idlist =
make_sequence (store_ident loc) idlist
and add_ident may_coerce id subst =
try
let (pos, cc) = Ident.find_same id map in
match cc with
Tcoerce_none ->
Ident.add id (Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])])) subst
Ident.add id
(Lprim(Pfield pos,
[Lprim(Pgetglobal glob, [], Location.none)],
Location.none))
subst
| _ ->
if may_coerce then subst else assert false
with Not_found ->
@ -874,9 +904,10 @@ let transl_store_structure glob map prims str =
and store_primitive (pos, prim) cont =
Lsequence(Lprim(Psetfield(pos, Pointer, Initialization),
[Lprim(Pgetglobal glob, []);
[Lprim(Pgetglobal glob, [], Location.none);
transl_primitive Location.none
prim.pc_desc prim.pc_env prim.pc_type None]),
prim.pc_desc prim.pc_env prim.pc_type None],
Location.none),
cont)
in List.fold_right store_primitive prims
@ -971,7 +1002,8 @@ let toploop_getvalue id =
Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=Lprim(Pfield toploop_getvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]);
[Lprim(Pgetglobal toploop_ident, [], Location.none)],
Location.none);
ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
@ -980,7 +1012,8 @@ let toploop_setvalue id lam =
Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=Lprim(Pfield toploop_setvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]);
[Lprim(Pgetglobal toploop_ident, [], Location.none)],
Location.none);
ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)));
lam];
ap_inlined=Default_inline;
@ -1046,7 +1079,8 @@ let transl_toplevel_item item =
[] ->
lambda_unit
| id :: ids ->
Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])),
Lsequence(toploop_setvalue id
(Lprim(Pfield pos, [Lvar mid], Location.none)),
set_idents (pos + 1) ids) in
Llet(Strict, Pgenval, mid,
transl_module Tcoerce_none None modl, set_idents 0 ids)
@ -1071,7 +1105,7 @@ let transl_toplevel_definition str =
let get_component = function
None -> Lconst const_unit
| Some id -> Lprim(Pgetglobal id, [])
| Some id -> Lprim(Pgetglobal id, [], Location.none)
let transl_package_flambda component_names coercion =
let size =
@ -1083,14 +1117,18 @@ let transl_package_flambda component_names coercion =
| Tcoerce_alias _ -> assert false
in
size,
apply_coercion Strict coercion
(Lprim(Pmakeblock(0, Immutable, None), List.map get_component component_names))
apply_coercion Location.none Strict coercion
(Lprim(Pmakeblock(0, Immutable, None),
List.map get_component component_names,
Location.none))
let transl_package component_names target_name coercion =
let components =
Lprim(Pmakeblock(0, Immutable, None),
List.map get_component component_names) in
Lprim(Psetglobal target_name, [apply_coercion Strict coercion components])
List.map get_component component_names, Location.none) in
Lprim(Psetglobal target_name,
[apply_coercion Location.none Strict coercion components],
Location.none)
(*
let components =
match coercion with
@ -1118,23 +1156,26 @@ let transl_store_package component_names target_name coercion =
make_sequence
(fun pos id ->
Lprim(Psetfield(pos, Pointer, Initialization),
[Lprim(Pgetglobal target_name, []);
get_component id]))
[Lprim(Pgetglobal target_name, [], Location.none);
get_component id],
Location.none))
0 component_names)
| Tcoerce_structure (pos_cc_list, _id_pos_list) ->
let components =
Lprim(Pmakeblock(0, Immutable, None),
List.map get_component component_names)
List.map get_component component_names,
Location.none)
in
let blk = Ident.create "block" in
(List.length pos_cc_list,
Llet (Strict, Pgenval, blk,
apply_coercion Strict coercion components,
apply_coercion Location.none Strict coercion components,
make_sequence
(fun pos _id ->
Lprim(Psetfield(pos, Pointer, Initialization),
[Lprim(Pgetglobal target_name, []);
Lprim(Pfield pos, [Lvar blk])]))
[Lprim(Pgetglobal target_name, [], Location.none);
Lprim(Pfield pos, [Lvar blk], Location.none)],
Location.none))
0 pos_cc_list))
(*
(* ignore id_pos_list as the ids are already bound *)

26
bytecomp/translobj.ml
View File

@ -58,9 +58,9 @@ let next_cache tag =
(tag, [!method_cache; Lconst(Const_base(Const_int n))])
let rec is_path = function
Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true
| Lprim (Pfield _, [lam]) -> is_path lam
| Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) ->
Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true
| Lprim (Pfield _, [lam], _) -> is_path lam
| Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) ->
is_path lam1 && is_path lam2
| _ -> false
@ -103,7 +103,7 @@ let transl_label_init_general f =
in
(*let expr =
List.fold_right
(fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr))
(fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr))
(Env.get_required_globals ()) expr
in
Env.reset_required_globals ();*)
@ -122,7 +122,9 @@ let transl_label_init_flambda f =
if !method_count = 0 then expr
else
Llet (Strict, Pgenval, method_cache_id,
Lprim (Pccall prim_makearray, [int !method_count; int 0]),
Lprim (Pccall prim_makearray,
[int !method_count; int 0],
Location.none),
expr)
in
transl_label_init_general (fun () -> expr, size)
@ -130,15 +132,20 @@ let transl_label_init_flambda f =
let transl_store_label_init glob size f arg =
assert(not Config.flambda);
assert(!Clflags.native_code);
method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]);
method_cache := Lprim(Pfield size,
[Lprim(Pgetglobal glob, [], Location.none)],
Location.none);
let expr = f arg in
let (size, expr) =
if !method_count = 0 then (size, expr) else
(size+1,
Lsequence(
Lprim(Psetfield(size, Pointer, Initialization),
[Lprim(Pgetglobal glob, []);
Lprim (Pccall prim_makearray, [int !method_count; int 0])]),
[Lprim(Pgetglobal glob, [], Location.none);
Lprim (Pccall prim_makearray,
[int !method_count; int 0],
Location.none)],
Location.none),
expr))
in
let lam, size = transl_label_init_general (fun () -> (expr, size)) in
@ -178,7 +185,8 @@ let oo_wrap env req f x =
(fun lambda id ->
Llet(StrictOpt, Pgenval, id,
Lprim(Pmakeblock(0, Mutable, None),
[lambda_unit; lambda_unit; lambda_unit]),
[lambda_unit; lambda_unit; lambda_unit],
Location.none),
lambda))
lambda !classes
in

116
middle_end/closure_conversion.ml
View File

@ -40,7 +40,7 @@ let add_default_argument_wrappers lam =
Primitive.simple ~name:Closure_conversion_aux.stub_hack_prim_name
~arity:1 ~alloc:false
in
Lprim (Pccall stub_prim, [body])
Lprim (Pccall stub_prim, [body], Location.none)
in
let defs_are_all_functions (defs : (_ * Lambda.lambda) list) =
List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs
@ -48,9 +48,9 @@ let add_default_argument_wrappers lam =
let f (lam : Lambda.lambda) : Lambda.lambda =
match lam with
| Llet (( Strict | Alias | StrictOpt), _k, id,
Lfunction {kind; params; body = fbody; attr}, body) ->
Lfunction {kind; params; body = fbody; attr; loc}, body) ->
begin match
Simplif.split_default_wrapper id kind params fbody attr
Simplif.split_default_wrapper id kind params fbody attr loc
~create_wrapper_body:stubify
with
| [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body)
@ -65,8 +65,8 @@ let add_default_argument_wrappers lam =
List.flatten
(List.map
(function
| (id, Lambda.Lfunction {kind; params; body; attr}) ->
Simplif.split_default_wrapper id kind params body attr
| (id, Lambda.Lfunction {kind; params; body; attr; loc}) ->
Simplif.split_default_wrapper id kind params body attr loc
~create_wrapper_body:stubify
| _ -> assert false)
defs)
@ -115,17 +115,12 @@ let rec eliminate_const_block (const : Lambda.structured_constant)
match const with
| Const_block (tag, consts) ->
Lprim (Pmakeblock (tag, Asttypes.Immutable, None),
List.map eliminate_const_block consts)
List.map eliminate_const_block consts, Location.none)
| Const_base _
| Const_pointer _
| Const_immstring _
| Const_float_array _ -> Lconst const
let default_debuginfo ?(inner_debuginfo = Debuginfo.none) env_debuginfo =
match env_debuginfo with
| None -> inner_debuginfo
| Some debuginfo -> debuginfo
let rec close_const t env (const : Lambda.structured_constant)
: Flambda.named * string =
match const with
@ -146,7 +141,7 @@ let rec close_const t env (const : Lambda.structured_constant)
| Const_block _ ->
Expr (close t env (eliminate_const_block const)), "const_block"
and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
and close t env (lam : Lambda.lambda) : Flambda.t =
match lam with
| Lvar id ->
begin match Env.find_var_exn env id with
@ -182,13 +177,11 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
initial_value = var;
body;
contents_kind = block_kind })
| Lfunction { kind; params; body; attr; } ->
| Lfunction { kind; params; body; attr; loc; } ->
let name =
(* Name anonymous functions by their source location, if known. *)
match body with
| Levent (_, { lev_loc }) ->
Format.asprintf "anon-fn[%a]" Location.print_compact lev_loc
| _ -> "anon-fn"
if loc = Location.none then "anon-fn"
else Format.asprintf "anon-fn[%a]" Location.print_compact loc
in
let closure_bound_var = Variable.create name in
(* CR-soon mshinwell: some of this is now very similar to the let rec case
@ -198,7 +191,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
let decl =
Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind
~params ~body ~inline:attr.inline ~specialise:attr.specialise
~is_a_functor:attr.is_a_functor
~is_a_functor:attr.is_a_functor ~loc
in
close_functions t env (Function_decls.create [decl])
in
@ -223,10 +216,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
func = func_var;
args;
kind = Indirect;
dbg =
default_debuginfo
~inner_debuginfo:(Debuginfo.from_location Dinfo_call ap_loc)
debuginfo;
dbg = Debuginfo.from_location ap_loc;
inline = ap_inlined;
specialise = ap_specialised;
})))
@ -240,7 +230,8 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
(* Identify any bindings in the [let rec] that are functions. These
will be named after the corresponding identifier in the [let rec]. *)
List.map (function
| (let_rec_ident, Lambda.Lfunction { kind; params; body; attr; }) ->
| (let_rec_ident,
Lambda.Lfunction { kind; params; body; attr; loc }) ->
let closure_bound_var =
Variable.create_with_same_name_as_ident let_rec_ident
in
@ -248,7 +239,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
Function_decl.create ~let_rec_ident:(Some let_rec_ident)
~closure_bound_var ~kind ~params ~body
~inline:attr.inline ~specialise:attr.specialise
~is_a_functor:attr.is_a_functor
~is_a_functor:attr.is_a_functor ~loc
in
Some function_declaration
| _ -> None)
@ -313,7 +304,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
| Lsend (kind, meth, obj, args, loc) ->
let meth_var = Variable.create "meth" in
let obj_var = Variable.create "obj" in
let dbg = Debuginfo.from_location Dinfo_call loc in
let dbg = Debuginfo.from_location loc in
Flambda.create_let meth_var (Expr (close t env meth))
(Flambda.create_let obj_var (Expr (close t env obj))
(Lift_code.lifting_helper (close_list t env args)
@ -321,7 +312,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
~name:"send_arg"
~create_body:(fun args ->
Send { kind; meth = meth_var; obj = obj_var; args; dbg; })))
| Lprim ((Pdivint | Pmodint) as prim, [arg1; arg2])
| Lprim ((Pdivint | Pmodint) as prim, [arg1; arg2], loc)
when not !Clflags.fast -> (* not -unsafe *)
let arg2 = close t env arg2 in
let arg1 = close t env arg1 in
@ -333,16 +324,16 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
let exn_symbol =
t.symbol_for_global' Predef.ident_division_by_zero
in
let dbg = Debuginfo.from_location loc in
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))
(Prim (Pintcomp Ceq, [zero; denominator], dbg))
(If_then_else (is_zero,
name_expr (Prim (Praise Raise_regular, [exn],
default_debuginfo debuginfo))
name_expr (Prim (Praise Raise_regular, [exn], dbg))
~name:"dummy",
(* CR-someday pchambart: find the right event.
mshinwell: I briefly looked at this, and couldn't
@ -351,13 +342,11 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
are suitable. I had to add a new one for a similar
case in the array data types work.
mshinwell: deferred CR *)
(* Debuginfo.from_raise event *)
name_expr ~name:"result"
(Prim (prim, [numerator; denominator],
Debuginfo.none))))))))
| Lprim ((Pdivint | Pmodint), _) when not !Clflags.fast ->
(Prim (prim, [numerator; denominator], dbg))))))))
| Lprim ((Pdivint | Pmodint), _, _) when not !Clflags.fast ->
Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments"
| Lprim (Psequor, [arg1; arg2]) ->
| Lprim (Psequor, [arg1; arg2], _) ->
let arg1 = close t env arg1 in
let arg2 = close t env arg2 in
let const_true = Variable.create "const_true" in
@ -365,7 +354,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
Flambda.create_let const_true (Const (Int 1))
(Flambda.create_let cond (Expr arg1)
(If_then_else (cond, Var const_true, arg2)))
| Lprim (Psequand, [arg1; arg2]) ->
| Lprim (Psequand, [arg1; arg2], _) ->
let arg1 = close t env arg1 in
let arg2 = close t env arg2 in
let const_false = Variable.create "const_false" in
@ -373,11 +362,11 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
Flambda.create_let const_false (Const (Int 0))
(Flambda.create_let cond (Expr arg1)
(If_then_else (cond, arg2, Var const_false)))
| Lprim ((Psequand | Psequor), _) ->
| Lprim ((Psequand | Psequor), _, _) ->
Misc.fatal_error "Psequand / Psequor must have exactly two arguments"
| Lprim (Pidentity, [arg]) -> close t env arg
| Lprim (Pdirapply loc, [funct; arg])
| Lprim (Prevapply loc, [arg; funct]) ->
| Lprim (Pidentity, [arg], _) -> close t env arg
| Lprim (Pdirapply, [funct; arg], loc)
| Lprim (Prevapply, [arg; funct], loc) ->
let apply : Lambda.lambda_apply =
{ ap_func = funct;
ap_args = [arg];
@ -390,32 +379,31 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
ap_specialised = Default_specialise;
}
in
close t env ?debuginfo (Lambda.Lapply apply)
| Lprim (Praise kind, [Levent (arg, event)]) ->
close t env (Lambda.Lapply apply)
| Lprim (Praise kind, [arg], loc) ->
let arg_var = Variable.create "raise_arg" in
let dbg = Debuginfo.from_location loc in
Flambda.create_let arg_var (Expr (close t env arg))
(name_expr
(Prim (Praise kind, [arg_var],
default_debuginfo ~inner_debuginfo:(Debuginfo.from_raise event)
debuginfo))
(Prim (Praise kind, [arg_var], dbg))
~name:"raise")
| Lprim (Pfield _, [Lprim (Pgetglobal id, [])])
| Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _)
when Ident.same id t.current_unit_id ->
Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \
unit is forbidden upon entry to the middle end"
| Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, []); _]) ->
| Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) ->
Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \
forbidden upon entry to the middle end"
| Lprim (Pgetglobal id, []) when Ident.is_predef_exn id ->
| Lprim (Pgetglobal id, [], _) when Ident.is_predef_exn id ->
let symbol = t.symbol_for_global' id in
t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
name_expr (Symbol symbol) ~name:"predef_exn"
| Lprim (Pgetglobal id, []) ->
| Lprim (Pgetglobal id, [], _) ->
assert (not (Ident.same id t.current_unit_id));
let symbol = t.symbol_for_global' id in
t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
name_expr (Symbol symbol) ~name:"Pgetglobal"
| Lprim (p, args) ->
| Lprim (p, args, loc) ->
(* One of the important consequences of the ANF-like representation
here is that we obtain names corresponding to the components of
blocks being made (with [Pmakeblock]). This information can be used
@ -423,14 +411,12 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
the allocation, since some field accesses can be tracked back to known
field values. *)
let name = Printlambda.name_of_primitive p in
let dbg = Debuginfo.from_location loc in
Lift_code.lifting_helper (close_list t env args)
~evaluation_order:`Right_to_left
~name:(name ^ "_arg")
~create_body:(fun args ->
let inner_debuginfo =
Debuginfo.from_filename Debuginfo.Dinfo_call t.filename
in
name_expr (Prim (p, args, default_debuginfo debuginfo ~inner_debuginfo))
name_expr (Prim (p, args, dbg))
~name)
| Lswitch (arg, sw) ->
let scrutinee = Variable.create "switch" in
@ -444,7 +430,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
blocks = List.map aux sw.sw_blocks;
failaction = Misc.may_map (close t env) sw.sw_failaction;
}))
| Lstringswitch (arg, sw, def) ->
| Lstringswitch (arg, sw, def, _) ->
let scrutinee = Variable.create "string_switch" in
Flambda.create_let scrutinee (Expr (close t env arg))
(String_switch (scrutinee,
@ -497,13 +483,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
let new_value_var = Variable.create "new_value" in
Flambda.create_let new_value_var (Expr (close t env new_value))
(Assign { being_assigned; new_value = new_value_var; })
| Levent (lam, ev) -> begin
match ev.lev_kind with
| Lev_after _ ->
close t env ~debuginfo:(Debuginfo.from_call ev) lam
| _ ->
close t env lam
end
| Levent (lam, _) -> close t env lam
| Lifused _ ->
(* [Lifused] is used to mark that this expression should be alive only if
an identifier is. Every use should have been removed by
@ -523,14 +503,8 @@ and close_functions t external_env function_declarations : Flambda.named =
let all_free_idents = Function_decls.all_free_idents function_declarations in
let close_one_function map decl =
let body = Function_decl.body decl in
let dbg =
(* Move any debugging event that may exist at the start of the function
body onto the function declaration itself. *)
match body with
| Levent (_, ({ lev_kind = Lev_function } as ev)) ->
Debuginfo.from_call ev
| _ -> Debuginfo.none
in
let loc = Function_decl.loc decl in
let dbg = Debuginfo.from_location loc in
let params = Function_decl.params decl in
(* Create fresh variables for the elements of the closure (cf.
the comment on [Function_decl.closure_env_without_parameters], above).
@ -603,14 +577,14 @@ and close_list t sb l = List.map (close t sb) l
and close_let_bound_expression t ?let_rec_ident let_bound_var env
(lam : Lambda.lambda) : Flambda.named =
match lam with
| Lfunction { kind; params; body; attr; } ->
| Lfunction { kind; params; body; attr; loc; } ->
(* Ensure that [let] and [let rec]-bound functions have appropriate
names. *)
let closure_bound_var = Variable.rename let_bound_var in
let decl =
Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~params
~body ~inline:attr.inline ~specialise:attr.specialise
~is_a_functor:attr.is_a_functor
~is_a_functor:attr.is_a_functor ~loc
in
let set_of_closures_var =
Variable.rename let_bound_var ~append:"_set_of_closures"

7
middle_end/closure_conversion_aux.ml
View File

@ -96,10 +96,11 @@ module Function_decls = struct
inline : Lambda.inline_attribute;
specialise : Lambda.specialise_attribute;
is_a_functor : bool;
loc : Location.t;
}
let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body ~inline
~specialise ~is_a_functor =
~specialise ~is_a_functor ~loc =
let let_rec_ident =
match let_rec_ident with
| None -> Ident.create "unnamed_function"
@ -114,6 +115,7 @@ module Function_decls = struct
inline;
specialise;
is_a_functor;
loc;
}
let let_rec_ident t = t.let_rec_ident
@ -125,10 +127,11 @@ module Function_decls = struct
let inline t = t.inline
let specialise t = t.specialise
let is_a_functor t = t.is_a_functor
let loc t = t.loc
let primitive_wrapper t =
match t.body with
| Lprim (Pccall { Primitive. prim_name; }, [body])
| Lprim (Pccall { Primitive. prim_name; }, [body], _)
when prim_name = stub_hack_prim_name -> Some body
| _ -> None
end

2
middle_end/closure_conversion_aux.mli
View File

@ -61,6 +61,7 @@ module Function_decls : sig
-> inline:Lambda.inline_attribute
-> specialise:Lambda.specialise_attribute
-> is_a_functor:bool
-> loc:Location.t
-> t
val let_rec_ident : t -> Ident.t
@ -71,6 +72,7 @@ module Function_decls : sig
val inline : t -> Lambda.inline_attribute
val specialise : t -> Lambda.specialise_attribute
val is_a_functor : t -> bool
val loc : t -> Location.t
(* [primitive_wrapper t] is [None] iff [t] is not a wrapper for a function
with default optional arguments. Otherwise it is [Some body], where

96
middle_end/debuginfo.ml Normal file
View File

@ -0,0 +1,96 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Lexing
open Location
type item = {
dinfo_file: string;
dinfo_line: int;
dinfo_char_start: int;
dinfo_char_end: int;
}
type t = item list
let none = []
let is_none = function
| [] -> true
| _ :: _ -> false
let to_string dbg =
match dbg with
| [] -> ""
| ds ->
let items =
List.map
(fun d ->
Printf.sprintf "%s:%d,%d-%d"
d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end)
ds
in
"{" ^ String.concat ";" items ^ "}"
let item_from_location loc =
{ dinfo_file = loc.loc_start.pos_fname;
dinfo_line = loc.loc_start.pos_lnum;
dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
dinfo_char_end =
if loc.loc_end.pos_fname = loc.loc_start.pos_fname
then loc.loc_end.pos_cnum - loc.loc_start.pos_bol
else loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
}
let from_location loc =
if loc == Location.none then [] else [item_from_location loc]
let to_location = function
| [] -> Location.none
| d :: _ ->
let loc_start =
{ pos_fname = d.dinfo_file;
pos_lnum = d.dinfo_line;
pos_bol = 0;
pos_cnum = d.dinfo_char_start;
} in
let loc_end = { loc_start with pos_cnum = d.dinfo_char_end; } in
{ loc_ghost = false; loc_start; loc_end; }
let inline loc t =
if loc == Location.none then t
else (item_from_location loc) :: t
let concat dbg1 dbg2 =
dbg1 @ dbg2
let compare dbg1 dbg2 =
let rec loop ds1 ds2 =
match ds1, ds2 with
| [], [] -> 0
| _ :: _, [] -> 1
| [], _ :: _ -> -1
| d1 :: ds1, d2 :: ds2 ->
let c = compare d1.dinfo_file d2.dinfo_file in
if c <> 0 then c else
let c = compare d1.dinfo_line d2.dinfo_line in
if c <> 0 then c else
let c = compare d1.dinfo_char_end d2.dinfo_char_end in
if c <> 0 then c else
let c = compare d1.dinfo_char_start d2.dinfo_char_start in
if c <> 0 then c else
loop ds1 ds2
in
loop (List.rev dbg1) (List.rev dbg2)

23
bytecomp/debuginfo.mli → middle_end/debuginfo.mli
View File

@ -13,30 +13,27 @@
(* *)
(**************************************************************************)
type kind = Dinfo_call | Dinfo_raise | Dinfo_inline of t
and t = private {
dinfo_kind: kind;
type item = private {
dinfo_file: string;
dinfo_line: int;
dinfo_char_start: int;
dinfo_char_end: int
}
val none: t
type t = item list
val is_none: t -> bool
val none : t
val to_string: t -> string
val is_none : t -> bool
val from_location: kind -> Location.t -> t
val from_filename: kind -> string -> t
val to_string : t -> string
val from_call: Lambda.lambda_event -> t
val from_raise: Lambda.lambda_event -> t
val from_location : Location.t -> t
val to_location: t -> Location.t
val to_location : t -> Location.t
val concat: t -> t -> t
val inline: Location.t -> t -> t
val unroll_inline_chain : t -> t * t list
val compare : t -> t -> int

4
middle_end/flambda_invariants.ml
View File

@ -466,8 +466,8 @@ let primitive_invariants flam ~no_access_to_global_module_identifiers =
raise (Access_to_global_module_identifier prim)
end
| Pidentity -> raise Pidentity_should_not_occur
| Pdirapply _ -> raise Pdirapply_should_be_expanded
| Prevapply _ -> raise Prevapply_should_be_expanded
| Pdirapply -> raise Pdirapply_should_be_expanded
| Prevapply -> raise Prevapply_should_be_expanded
| _ -> ()
end
| _ -> ())

4
middle_end/inline_and_simplify.ml
View File

@ -593,7 +593,7 @@ and simplify_set_of_closures original_env r
E.enter_closure closure_env ~closure_id:(Closure_id.wrap fun_var)
~inline_inside:
(Inlining_decision.should_inline_inside_declaration function_decl)
~debuginfo:function_decl.dbg
~dbg:function_decl.dbg
~f:(fun body_env -> simplify body_env r function_decl.body)
in
let inline : Lambda.inline_attribute =
@ -1374,7 +1374,7 @@ and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures)
E.enter_closure closure_env
~closure_id:(Closure_id.wrap fun_var)
~inline_inside:false
~debuginfo:function_decl.dbg
~dbg:function_decl.dbg
~f:(fun body_env ->
simplify body_env (R.create ()) function_decl.body)
in

16
middle_end/inline_and_simplify_aux.ml
View File

@ -351,22 +351,22 @@ module Env = struct
let freshening t = t.freshening
let never_inline t = t.never_inline || t.never_inline_outside_closures
let note_entering_closure t ~closure_id ~debuginfo =
let note_entering_closure t ~closure_id ~dbg =
if t.never_inline then t
else
{ t with
inlining_stats_closure_stack =
Inlining_stats.Closure_stack.note_entering_closure
t.inlining_stats_closure_stack ~closure_id ~debuginfo;
t.inlining_stats_closure_stack ~closure_id ~dbg;
}
let note_entering_call t ~closure_id ~debuginfo =
let note_entering_call t ~closure_id ~dbg =
if t.never_inline then t
else
{ t with
inlining_stats_closure_stack =
Inlining_stats.Closure_stack.note_entering_call
t.inlining_stats_closure_stack ~closure_id ~debuginfo;
t.inlining_stats_closure_stack ~closure_id ~dbg;
}
let note_entering_inlined t =
@ -387,20 +387,20 @@ module Env = struct
t.inlining_stats_closure_stack ~closure_ids;
}
let enter_closure t ~closure_id ~inline_inside ~debuginfo ~f =
let enter_closure t ~closure_id ~inline_inside ~dbg ~f =
let t =
if inline_inside && not t.never_inline_inside_closures then t
else set_never_inline t
in
let t = unset_never_inline_outside_closures t in
f (note_entering_closure t ~closure_id ~debuginfo)
f (note_entering_closure t ~closure_id ~dbg)
let record_decision t decision =
Inlining_stats.record_decision decision
~closure_stack:t.inlining_stats_closure_stack
let inline_debuginfo t ~dbg =
{ t with inlined_debuginfo = Debuginfo.concat dbg t.inlined_debuginfo }
let set_inline_debuginfo t ~dbg =
{ t with inlined_debuginfo = dbg }
let add_inlined_debuginfo t ~dbg =
Debuginfo.concat t.inlined_debuginfo dbg

15
middle_end/inline_and_simplify_aux.mli
View File

@ -208,7 +208,7 @@ module Env : sig
val note_entering_closure
: t
-> closure_id:Closure_id.t
-> debuginfo:Debuginfo.t
-> dbg:Debuginfo.t
-> t
(** If collecting inlining statistics, record that the inliner is about to
@ -218,7 +218,7 @@ module Env : sig
val note_entering_call
: t
-> closure_id:Closure_id.t
-> debuginfo:Debuginfo.t
-> dbg:Debuginfo.t
-> t
(** If collecting inlining statistics, record that the inliner is about to
@ -239,7 +239,7 @@ module Env : sig
: t
-> closure_id:Closure_id.t
-> inline_inside:bool
-> debuginfo:Debuginfo.t
-> dbg:Debuginfo.t
-> f:(t -> 'a)
-> 'a
@ -254,12 +254,9 @@ module Env : sig
(** Print a human-readable version of the given environment. *)
val print : Format.formatter -> t -> unit
(** The environment maintains a list of sites that got inlined to produce
precise location information.
When inlining a call-site, call this function to concatenate the
call-site location to the existing list of sites. *)
val inline_debuginfo : t -> dbg:Debuginfo.t -> t
(** The environment stores the call-site being inlined to produce precise location
information. This function sets the current call-site being inlined. *)
val set_inline_debuginfo : t -> dbg:Debuginfo.t -> t
(** Appends the locations of inlined call-sites to the [~dbg] argument *)
val add_inlined_debuginfo : t -> dbg:Debuginfo.t -> Debuginfo.t

2
middle_end/inlining_decision.ml
View File

@ -543,7 +543,7 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
let env = E.unset_never_inline_inside_closures env in
let env =
E.note_entering_call env
~closure_id:closure_id_being_applied ~debuginfo:dbg
~closure_id:closure_id_being_applied ~dbg:dbg
in
let max_level =
Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth

16
middle_end/inlining_stats.ml
View File

@ -27,23 +27,23 @@ module Closure_stack = struct
let create () = []
let note_entering_closure t ~closure_id ~debuginfo =
let note_entering_closure t ~closure_id ~dbg =
if not !Clflags.inlining_report then t
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _->
(Closure (closure_id, debuginfo)) :: t
(Closure (closure_id, dbg)) :: t
| (Call _) :: _ ->
Misc.fatal_errorf "note_entering_closure: unexpected Call node"
(* CR-someday lwhite: since calls do not have a unique id it is possible
some calls will end up sharing nodes. *)
let note_entering_call t ~closure_id ~debuginfo =
let note_entering_call t ~closure_id ~dbg =
if not !Clflags.inlining_report then t
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _ ->
(Call (closure_id, debuginfo)) :: t
(Call (closure_id, dbg)) :: t
| (Call _) :: _ ->
Misc.fatal_errorf "note_entering_call: unexpected Call node"
@ -91,13 +91,7 @@ module Inlining_report = struct
type t = Debuginfo.t * Closure_id.t * kind
let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) =
let c = compare d1.dinfo_file d2.dinfo_file in
if c <> 0 then c else
let c = compare d1.dinfo_line d2.dinfo_line in
if c <> 0 then c else
let c = compare d1.dinfo_char_end d2.dinfo_char_end in
if c <> 0 then c else
let c = compare d1.dinfo_char_start d2.dinfo_char_start in
let c = Debuginfo.compare d1 d2 in
if c <> 0 then c else
let c = Closure_id.compare cl1 cl2 in
if c <> 0 then c else

4
middle_end/inlining_stats.mli
View File

@ -24,13 +24,13 @@ module Closure_stack : sig
val note_entering_closure
: t
-> closure_id:Closure_id.t
-> debuginfo:Debuginfo.t
-> dbg:Debuginfo.t
-> t
val note_entering_call
: t
-> closure_id:Closure_id.t
-> debuginfo:Debuginfo.t
-> dbg:Debuginfo.t
-> t
val note_entering_inlined : t -> t

2
middle_end/inlining_transforms.ml
View File

@ -175,7 +175,7 @@ let inline_by_copying_function_body ~env ~r
bindings_for_vars_bound_by_closure_and_params_to_args
in
let env = E.activate_freshening (E.set_never_inline env) in
let env = E.inline_debuginfo ~dbg env in
let env = E.set_inline_debuginfo ~dbg env in
simplify env r expr
let inline_by_copying_function_declaration ~env ~r

3
middle_end/remove_unused_arguments.ml
View File

@ -78,13 +78,12 @@ let make_stub unused var (fun_decl : Flambda.function_declaration)
in
let args = List.map (fun (_, var) -> var) used_args' in
let kind = Flambda.Direct (Closure_id.wrap renamed) in
let dbg = fun_decl.dbg in
let body : Flambda.t =
Apply {
func = renamed;
args;
kind;
dbg;
dbg = fun_decl.dbg;
inline = Default_inline;
specialise = Default_specialise;
}

4
middle_end/semantics_of_primitives.ml
View File

@ -135,8 +135,8 @@ let for_primitive (prim : Lambda.primitive) =
| Popaque -> Arbitrary_effects, Has_coeffects
| Ploc _ ->
Misc.fatal_error "[Ploc] should have been eliminated by [Translcore]"
| Prevapply _
| Pdirapply _
| Prevapply
| Pdirapply
| Psequand
| Psequor ->
Misc.fatal_errorf "The primitive %a should have been eliminated by the \

1
testsuite/tests/asmcomp/Makefile
View File

@ -18,6 +18,7 @@ BASEDIR=../..
INCLUDES=\
-I $(OTOPDIR)/utils \
-I $(OTOPDIR)/typing \
-I $(OTOPDIR)/middle_end \
-I $(OTOPDIR)/bytecomp \
-I $(OTOPDIR)/asmcomp

16
testsuite/tests/backtrace/Makefile
View File

@ -42,7 +42,7 @@ byte:
(OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
$(OCAMLRUN) $(EXECNAME) $$arg || true) \
>$$F.$$arg.byte.result 2>&1; \
$(DIFF) $$F.$$arg.reference $$F.$$arg.byte.result >/dev/null \
$(DIFF) $$F.$$arg.byte.reference $$F.$$arg.byte.result >/dev/null \
&& echo " => passed" || echo " => failed"; \
done; \
done
@ -54,7 +54,7 @@ byte:
(OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
$(OCAMLRUN) $(EXECNAME) $$arg || true) \
>$$F.byte.result 2>&1; \
$(DIFF) $$F.reference $$F.byte.result >/dev/null \
$(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
&& echo " => passed" || echo " => failed"; \
done;
@for file in $(INLININGFILES); \
@ -66,7 +66,7 @@ byte:
(OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
$(OCAMLRUN) $(EXECNAME) $$arg 2>&1 || true) \
| $(LOCATIONFILTER) >$$F.byte.result 2>&1; \
$(DIFF) $$F.reference $$F.byte.result >/dev/null \
$(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
&& echo " => passed" || echo " => failed"; \
done
@ -94,7 +94,7 @@ native:
(OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
./$(EXECNAME) $$arg || true) \
>$$F.$$arg.native.result 2>&1; \
$(DIFF) $$F.$$arg.reference $$F.$$arg.native.result >/dev/null \
$(DIFF) $$F.$$arg.native.reference $$F.$$arg.native.result >/dev/null \
&& echo " => passed" || echo " => failed"; \
done; \
done
@ -106,7 +106,7 @@ native:
(OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
./$(EXECNAME) $$arg || true) \
>$$F.native.result 2>&1; \
$(DIFF) $$F.reference $$F.native.result >/dev/null \
$(DIFF) $$F.native.reference $$F.native.result >/dev/null \
&& echo " => passed" || echo " => failed"; \
done;
@for file in $(OTHERFILESNOINLINING) $(OTHERFILESNOINLINING_NATIVE); \
@ -118,7 +118,7 @@ native:
(OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
./$(EXECNAME) $$arg || true) \
>$$F.native.result 2>&1; \
$(DIFF) $$F.reference $$F.native.result >/dev/null \
$(DIFF) $$F.native.reference $$F.native.result >/dev/null \
&& echo " => passed" || echo " => failed"; \
done;
@for file in $(INLININGFILES); \
@ -130,7 +130,7 @@ native:
(OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
./$(EXECNAME) $$arg 2>&1 || true) \
| $(LOCATIONFILTER) >$$F.native.result; \
$(DIFF) $$F.reference $$F.native.result >/dev/null \
$(DIFF) $$F.native.reference $$F.native.result >/dev/null \
&& echo " => passed" || echo " => failed"; \
rm -f program program.exe; \
$(OCAMLOPT) -g -o $(EXECNAME) -O3 $$file; \
@ -139,7 +139,7 @@ native:
(OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
./$(EXECNAME) $$arg 2>&1 || true) \
| $(LOCATIONFILTER) >$$F.O3.result; \
$(DIFF) $$F.reference $$F.O3.result >/dev/null \
$(DIFF) $$F.native.reference $$F.O3.result >/dev/null \
&& echo " => passed" || echo " => failed"; \
done

0
testsuite/tests/backtrace/backtrace..reference → testsuite/tests/backtrace/backtrace..byte.reference
View File

2
testsuite/tests/backtrace/backtrace..native.reference Normal file
View File

@ -0,0 +1,2 @@
Fatal error: exception Invalid_argument("index out of bounds")
Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24

0
testsuite/tests/backtrace/backtrace.a.reference → testsuite/tests/backtrace/backtrace.a.byte.reference
View File

1
testsuite/tests/backtrace/backtrace.a.native.reference Normal file
View File

@ -0,0 +1 @@
a

0
testsuite/tests/backtrace/backtrace.b.reference → testsuite/tests/backtrace/backtrace.b.byte.reference
View File

11
testsuite/tests/backtrace/backtrace.b.native.reference Normal file
View File

@ -0,0 +1,11 @@
b
Fatal error: exception Backtrace.Error("b")
Raised at file "backtrace.ml", line 7, characters 16-32
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 11, characters 4-11
Re-raised at file "backtrace.ml", line 13, characters 62-71
Called from file "backtrace.ml", line 18, characters 9-25

0
testsuite/tests/backtrace/backtrace.c.reference → testsuite/tests/backtrace/backtrace.c.byte.reference
View File

3
testsuite/tests/backtrace/backtrace.c.native.reference Normal file
View File

@ -0,0 +1,3 @@
Fatal error: exception Backtrace.Error("c")
Raised at file "backtrace.ml", line 14, characters 20-37
Called from file "backtrace.ml", line 18, characters 9-25

0
testsuite/tests/backtrace/backtrace.d.reference → testsuite/tests/backtrace/backtrace.d.byte.reference
View File

9
testsuite/tests/backtrace/backtrace.d.native.reference Normal file
View File

@ -0,0 +1,9 @@
Fatal error: exception Backtrace.Error("d")
Raised at file "backtrace.ml", line 7, characters 16-32
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 7, characters 42-53
Called from file "backtrace.ml", line 11, characters 4-11
Called from file "backtrace.ml", line 18, characters 9-25

0
testsuite/tests/backtrace/backtrace2.reference → testsuite/tests/backtrace/backtrace2.byte.reference
View File

27
testsuite/tests/backtrace/backtrace2.native.reference Normal file
View File

@ -0,0 +1,27 @@
a
No exception
b
Uncaught exception Backtrace2.Error("b")
Raised at file "backtrace2.ml", line 7, characters 16-32
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 11, characters 4-11
Re-raised at file "backtrace2.ml", line 13, characters 62-71
Called from file "backtrace2.ml", line 18, characters 11-23
Uncaught exception Backtrace2.Error("c")
Raised at file "backtrace2.ml", line 14, characters 20-37
Called from file "backtrace2.ml", line 18, characters 11-23
Uncaught exception Backtrace2.Error("d")
Raised at file "backtrace2.ml", line 7, characters 16-32
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 7, characters 42-53
Called from file "backtrace2.ml", line 11, characters 4-11
Called from file "backtrace2.ml", line 18, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22

0
testsuite/tests/backtrace/backtrace3.reference → testsuite/tests/backtrace/backtrace3.byte.reference
View File

27
testsuite/tests/backtrace/backtrace3.native.reference Normal file
View File

@ -0,0 +1,27 @@
a
No exception
b
Uncaught exception Backtrace3.Error("b")
Raised at file "backtrace3.ml", line 7, characters 16-32
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 11, characters 4-11
Re-raised at file "backtrace3.ml", line 20, characters 41-50
Called from file "backtrace3.ml", line 28, characters 11-23
Uncaught exception Backtrace3.Error("c")
Raised at file "backtrace3.ml", line 24, characters 6-23
Called from file "backtrace3.ml", line 28, characters 11-23
Uncaught exception Backtrace3.Error("d")
Raised at file "backtrace3.ml", line 7, characters 16-32
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 7, characters 42-53
Called from file "backtrace3.ml", line 11, characters 4-11
Called from file "backtrace3.ml", line 28, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22

0
testsuite/tests/backtrace/backtrace_deprecated.reference → testsuite/tests/backtrace/backtrace_deprecated.byte.reference
View File

27
testsuite/tests/backtrace/backtrace_deprecated.native.reference Normal file
View File

@ -0,0 +1,27 @@
a
No exception
b
Uncaught exception Backtrace_deprecated.Error("b")
Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 14, characters 4-11
Re-raised at file "backtrace_deprecated.ml", line 16, characters 62-71
Called from file "backtrace_deprecated.ml", line 21, characters 11-23
Uncaught exception Backtrace_deprecated.Error("c")
Raised at file "backtrace_deprecated.ml", line 17, characters 20-37
Called from file "backtrace_deprecated.ml", line 21, characters 11-23
Uncaught exception Backtrace_deprecated.Error("d")
Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 10, characters 42-53
Called from file "backtrace_deprecated.ml", line 14, characters 4-11
Called from file "backtrace_deprecated.ml", line 21, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22

0
testsuite/tests/backtrace/backtrace_slots.reference → testsuite/tests/backtrace/backtrace_slots.byte.reference
View File

27
testsuite/tests/backtrace/backtrace_slots.native.reference Normal file
View File

@ -0,0 +1,27 @@
a
No exception
b
Uncaught exception Backtrace_slots.Error("b")
Raised at file "backtrace_slots.ml", line 36, characters 16-32
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 40, characters 4-11
Re-raised at file "backtrace_slots.ml", line 42, characters 62-71
Called from file "backtrace_slots.ml", line 47, characters 11-23
Uncaught exception Backtrace_slots.Error("c")
Raised at file "backtrace_slots.ml", line 43, characters 20-37
Called from file "backtrace_slots.ml", line 47, characters 11-23
Uncaught exception Backtrace_slots.Error("d")
Raised at file "backtrace_slots.ml", line 36, characters 16-32
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 36, characters 42-53
Called from file "backtrace_slots.ml", line 40, characters 4-11
Called from file "backtrace_slots.ml", line 47, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22

0
testsuite/tests/backtrace/backtraces_and_finalizers.reference → testsuite/tests/backtrace/backtraces_and_finalizers.native.reference
View File

21
testsuite/tests/backtrace/inline_test.byte.reference
View File

@ -1,6 +1,15 @@
Fatal error: exception Failure("test")
Raised at file "inline_test.ml", line 5, characters 8-24
Called from file "inline_test.ml", line 8, characters 2-5
Called from file "inline_test.ml", line 11, characters 12-17
Called from file "inline_test.ml", line 14, characters 5-8
Called from file "inline_test.ml", line 18, characters 2-6
inline_test.ml
line 5
characters 8-24
inline_test.ml
line 8
characters 2-5
inline_test.ml
line 11
characters 12-17
inline_test.ml
line 14
characters 5-8
inline_test.ml
line 18
characters 2-6

2
testsuite/tests/backtrace/inline_test.reference → testsuite/tests/backtrace/inline_test.native.reference
View File

@ -1,6 +1,6 @@
inline_test.ml
line 5
characters 8-24
characters 2-24
inline_test.ml
line 8
characters 2-5

0
testsuite/tests/backtrace/inline_traversal_test.reference → testsuite/tests/backtrace/inline_traversal_test.byte.reference
View File

5
testsuite/tests/backtrace/inline_traversal_test.native.reference Normal file
View File

@ -0,0 +1,5 @@
inline_traversal_test.ml:5
inline_traversal_test.ml:8
inline_traversal_test.ml:11
inline_traversal_test.ml:14
inline_traversal_test.ml:19

0
testsuite/tests/backtrace/pr6920_why_at.reference → testsuite/tests/backtrace/pr6920_why_at.byte.reference
View File

4
testsuite/tests/backtrace/pr6920_why_at.native.reference Normal file
View File

@ -0,0 +1,4 @@
Fatal error: exception Pervasives.Exit
Raised at file "pr6920_why_at.ml", line 1, characters 35-45
Called from file "pr6920_why_at.ml", line 3, characters 2-11
Called from file "pr6920_why_at.ml", line 9, characters 2-6

0
testsuite/tests/backtrace/pr6920_why_swallow.reference → testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
View File

4
testsuite/tests/backtrace/pr6920_why_swallow.native.reference Normal file
View File

@ -0,0 +1,4 @@
Fatal error: exception Pervasives.Exit
Raised at file "pr6920_why_swallow.ml", line 1, characters 35-45
Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
Called from file "pr6920_why_swallow.ml", line 11, characters 2-6

0
testsuite/tests/backtrace/raw_backtrace.reference → testsuite/tests/backtrace/raw_backtrace.byte.reference
View File

27
testsuite/tests/backtrace/raw_backtrace.native.reference Normal file
View File

@ -0,0 +1,27 @@
a
No exception
b
Uncaught exception Raw_backtrace.Error("b")
Raised at file "raw_backtrace.ml", line 7, characters 16-32
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 11, characters 4-11
Re-raised at file "raw_backtrace.ml", line 13, characters 62-71
Called from file "raw_backtrace.ml", line 18, characters 11-23
Uncaught exception Raw_backtrace.Error("c")
Raised at file "raw_backtrace.ml", line 14, characters 20-37
Called from file "raw_backtrace.ml", line 18, characters 11-23
Uncaught exception Raw_backtrace.Error("d")
Raised at file "raw_backtrace.ml", line 7, characters 16-32
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 7, characters 42-53
Called from file "raw_backtrace.ml", line 11, characters 4-11
Called from file "raw_backtrace.ml", line 18, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
Raised by primitive operation at file "raw_backtrace.ml", line 18, characters 14-22

6
toplevel/opttoploop.ml
View File

@ -84,7 +84,11 @@ let close_phrase lam =
let open Lambda in
IdentSet.fold (fun id l ->
let glb, pos = toplevel_value id in
let glob = Lprim (Pfield pos, [Lprim (Pgetglobal glb, [])]) in
let glob =
Lprim (Pfield pos,
[Lprim (Pgetglobal glb, [], Location.none)],
Location.none)
in
Llet(Strict, Pgenval, id, glob, l)
) (free_variables lam) lam