From 2b5f13c913471194b246f986f337778312ec9661 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Wed, 26 Sep 2018 09:50:42 +0100 Subject: [PATCH] GPR#2056 (Backend_var) --- .depend | 184 +++++++------- Changes | 4 + Makefile | 1 + asmcomp/afl_instrument.ml | 30 ++- asmcomp/backend_var.ml | 87 +++++++ asmcomp/backend_var.mli | 54 ++++ asmcomp/clambda.ml | 22 +- asmcomp/clambda.mli | 22 +- asmcomp/closure.ml | 129 +++++----- asmcomp/cmm.ml | 16 +- asmcomp/cmm.mli | 20 +- asmcomp/cmmgen.ml | 140 ++++++----- asmcomp/debug/available_regs.ml | 4 +- asmcomp/debug/reg_availability_set.ml | 15 +- asmcomp/debug/reg_with_debug_info.ml | 10 +- asmcomp/debug/reg_with_debug_info.mli | 4 +- asmcomp/flambda_to_clambda.ml | 41 +-- asmcomp/mach.ml | 2 +- asmcomp/mach.mli | 2 +- asmcomp/printclambda.ml | 27 +- asmcomp/printcmm.ml | 19 +- asmcomp/printmach.ml | 4 +- asmcomp/reg.ml | 10 +- asmcomp/reg.mli | 2 +- asmcomp/selectgen.ml | 42 ++-- asmcomp/selectgen.mli | 10 +- asmcomp/spacetime_profiling.ml | 106 ++++---- asmcomp/strmatch.ml | 11 +- asmcomp/un_anf.ml | 342 +++++++++++++------------- testsuite/tools/parsecmmaux.ml | 8 +- testsuite/tools/parsecmmaux.mli | 6 +- tools/Makefile | 2 + 32 files changed, 810 insertions(+), 566 deletions(-) create mode 100644 asmcomp/backend_var.ml create mode 100644 asmcomp/backend_var.mli diff --git a/.depend b/.depend index 856e7e6d7..53b34b615 100644 --- a/.depend +++ b/.depend @@ -332,11 +332,11 @@ typing/printtyped.cmx : typing/types.cmx typing/typedtree.cmx \ parsing/asttypes.cmi typing/printtyped.cmi typing/printtyped.cmi : typing/typedtree.cmi typing/rec_check.cmo : typing/types.cmi typing/typeopt.cmi \ - typing/typedtree.cmi typing/primitive.cmi typing/path.cmi utils/misc.cmi \ + typing/typedtree.cmi typing/primitive.cmi typing/path.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi \ typing/rec_check.cmi typing/rec_check.cmx : typing/types.cmx typing/typeopt.cmx \ - typing/typedtree.cmx typing/primitive.cmx typing/path.cmx utils/misc.cmx \ + typing/typedtree.cmx typing/primitive.cmx typing/path.cmx \ bytecomp/lambda.cmx typing/ident.cmx parsing/asttypes.cmi \ typing/rec_check.cmi typing/rec_check.cmi : typing/typedtree.cmi typing/ident.cmi @@ -756,11 +756,11 @@ asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ asmcomp/cmm.cmx asmcomp/CSEgen.cmi asmcomp/CSEgen.cmi : asmcomp/mach.cmi -asmcomp/afl_instrument.cmo : bytecomp/lambda.cmi typing/ident.cmi \ - middle_end/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.cmi \ +asmcomp/afl_instrument.cmo : bytecomp/lambda.cmi middle_end/debuginfo.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/backend_var.cmi \ parsing/asttypes.cmi asmcomp/afl_instrument.cmi -asmcomp/afl_instrument.cmx : bytecomp/lambda.cmx typing/ident.cmx \ - middle_end/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \ +asmcomp/afl_instrument.cmx : bytecomp/lambda.cmx middle_end/debuginfo.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/backend_var.cmx \ parsing/asttypes.cmi asmcomp/afl_instrument.cmi asmcomp/afl_instrument.cmi : asmcomp/cmm.cmi asmcomp/arch.cmo : utils/config.cmi utils/clflags.cmi @@ -836,6 +836,12 @@ asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ utils/clflags.cmx utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ asmcomp/asmpackager.cmi asmcomp/asmpackager.cmi : typing/env.cmi middle_end/backend_intf.cmi +asmcomp/backend_var.cmo : typing/printtyp.cmi typing/path.cmi \ + typing/ident.cmi middle_end/debuginfo.cmi asmcomp/backend_var.cmi +asmcomp/backend_var.cmx : typing/printtyp.cmx typing/path.cmx \ + typing/ident.cmx middle_end/debuginfo.cmx asmcomp/backend_var.cmi +asmcomp/backend_var.cmi : typing/path.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi asmcomp/branch_relaxation.cmo : utils/misc.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/branch_relaxation_intf.cmo \ asmcomp/branch_relaxation.cmi @@ -876,26 +882,26 @@ asmcomp/build_export_info.cmx : middle_end/base_types/variable.cmx \ asmcomp/build_export_info.cmi asmcomp/build_export_info.cmi : middle_end/flambda.cmi \ asmcomp/export_info.cmi middle_end/backend_intf.cmi -asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ - middle_end/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi -asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \ - middle_end/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi -asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ - middle_end/debuginfo.cmi parsing/asttypes.cmi +asmcomp/clambda.cmo : bytecomp/lambda.cmi middle_end/debuginfo.cmi \ + asmcomp/backend_var.cmi parsing/asttypes.cmi asmcomp/clambda.cmi +asmcomp/clambda.cmx : bytecomp/lambda.cmx middle_end/debuginfo.cmx \ + asmcomp/backend_var.cmx parsing/asttypes.cmi asmcomp/clambda.cmi +asmcomp/clambda.cmi : bytecomp/lambda.cmi middle_end/debuginfo.cmi \ + asmcomp/backend_var.cmi parsing/asttypes.cmi asmcomp/closure.cmo : utils/warnings.cmi bytecomp/switch.cmi \ bytecomp/simplif.cmi bytecomp/semantics_of_primitives.cmi \ typing/primitive.cmi utils/numbers.cmi utils/misc.cmi \ - parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/env.cmi \ middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ - utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ - asmcomp/arch.cmo asmcomp/closure.cmi + utils/clflags.cmi asmcomp/clambda.cmi asmcomp/backend_var.cmi \ + parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/closure.cmi asmcomp/closure.cmx : utils/warnings.cmx bytecomp/switch.cmx \ bytecomp/simplif.cmx bytecomp/semantics_of_primitives.cmx \ typing/primitive.cmx utils/numbers.cmx utils/misc.cmx \ - parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/env.cmx \ middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ - utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ - asmcomp/arch.cmx asmcomp/closure.cmi + utils/clflags.cmx asmcomp/clambda.cmx asmcomp/backend_var.cmx \ + parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi asmcomp/closure_offsets.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi utils/misc.cmi \ @@ -907,27 +913,27 @@ asmcomp/closure_offsets.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/closure_id.cmx asmcomp/closure_offsets.cmi asmcomp/closure_offsets.cmi : middle_end/base_types/var_within_closure.cmi \ middle_end/flambda.cmi middle_end/base_types/closure_id.cmi -asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \ - middle_end/debuginfo.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ +asmcomp/cmm.cmo : bytecomp/lambda.cmi middle_end/debuginfo.cmi \ + asmcomp/backend_var.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ asmcomp/cmm.cmi -asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \ - middle_end/debuginfo.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ +asmcomp/cmm.cmx : bytecomp/lambda.cmx middle_end/debuginfo.cmx \ + asmcomp/backend_var.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ asmcomp/cmm.cmi -asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi \ - middle_end/debuginfo.cmi parsing/asttypes.cmi +asmcomp/cmm.cmi : bytecomp/lambda.cmi middle_end/debuginfo.cmi \ + asmcomp/backend_var.cmi parsing/asttypes.cmi asmcomp/cmmgen.cmo : asmcomp/un_anf.cmi typing/types.cmi bytecomp/switch.cmi \ asmcomp/strmatch.cmi asmcomp/proc.cmi bytecomp/printlambda.cmi \ typing/primitive.cmi utils/numbers.cmi utils/misc.cmi bytecomp/lambda.cmi \ - typing/ident.cmi middle_end/debuginfo.cmi utils/config.cmi \ - asmcomp/compilenv.cmi asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ - utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ + middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/clambda.cmi asmcomp/backend_var.cmi parsing/asttypes.cmi \ asmcomp/arch.cmo asmcomp/afl_instrument.cmi asmcomp/cmmgen.cmi asmcomp/cmmgen.cmx : asmcomp/un_anf.cmx typing/types.cmx bytecomp/switch.cmx \ asmcomp/strmatch.cmx asmcomp/proc.cmx bytecomp/printlambda.cmx \ typing/primitive.cmx utils/numbers.cmx utils/misc.cmx bytecomp/lambda.cmx \ - typing/ident.cmx middle_end/debuginfo.cmx utils/config.cmx \ - asmcomp/compilenv.cmx asmcomp/cmx_format.cmi asmcomp/cmm.cmx \ - utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ + middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/clambda.cmx asmcomp/backend_var.cmx parsing/asttypes.cmi \ asmcomp/arch.cmx asmcomp/afl_instrument.cmx asmcomp/cmmgen.cmi asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ asmcomp/clambda.cmi @@ -1039,12 +1045,12 @@ asmcomp/flambda_to_clambda.cmo : middle_end/base_types/variable.cmi \ middle_end/parameter.cmi utils/numbers.cmi \ middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ middle_end/base_types/linkage_name.cmi \ - middle_end/initialize_symbol_to_let_symbol.cmi typing/ident.cmi \ + middle_end/initialize_symbol_to_let_symbol.cmi \ middle_end/flambda_utils.cmi middle_end/flambda.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 + utils/clflags.cmi asmcomp/clambda.cmi asmcomp/backend_var.cmi \ + middle_end/allocated_const.cmi asmcomp/flambda_to_clambda.cmi asmcomp/flambda_to_clambda.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/var_within_closure.cmx \ middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ @@ -1054,12 +1060,12 @@ asmcomp/flambda_to_clambda.cmx : middle_end/base_types/variable.cmx \ middle_end/parameter.cmx utils/numbers.cmx \ middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ middle_end/base_types/linkage_name.cmx \ - middle_end/initialize_symbol_to_let_symbol.cmx typing/ident.cmx \ + middle_end/initialize_symbol_to_let_symbol.cmx \ middle_end/flambda_utils.cmx middle_end/flambda.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 + utils/clflags.cmx asmcomp/clambda.cmx asmcomp/backend_var.cmx \ + middle_end/allocated_const.cmx asmcomp/flambda_to_clambda.cmi asmcomp/flambda_to_clambda.cmi : middle_end/base_types/symbol.cmi \ middle_end/flambda.cmi asmcomp/export_info.cmi asmcomp/clambda.cmi asmcomp/import_approx.cmo : middle_end/base_types/variable.cmi \ @@ -1113,28 +1119,28 @@ asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ asmcomp/cmm.cmx asmcomp/liveness.cmi asmcomp/liveness.cmi : asmcomp/mach.cmi asmcomp/mach.cmo : asmcomp/debug/reg_with_debug_info.cmi \ - asmcomp/debug/reg_availability_set.cmi asmcomp/reg.cmi typing/ident.cmi \ - middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/mach.cmi + asmcomp/debug/reg_availability_set.cmi asmcomp/reg.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/backend_var.cmi \ + asmcomp/arch.cmo asmcomp/mach.cmi asmcomp/mach.cmx : asmcomp/debug/reg_with_debug_info.cmx \ - asmcomp/debug/reg_availability_set.cmx asmcomp/reg.cmx typing/ident.cmx \ - middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/mach.cmi + asmcomp/debug/reg_availability_set.cmx asmcomp/reg.cmx \ + middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/backend_var.cmx \ + asmcomp/arch.cmx asmcomp/mach.cmi asmcomp/mach.cmi : asmcomp/debug/reg_availability_set.cmi asmcomp/reg.cmi \ - typing/ident.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/backend_var.cmi \ asmcomp/arch.cmo asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \ - typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ + asmcomp/clambda.cmi asmcomp/backend_var.cmi parsing/asttypes.cmi \ asmcomp/printclambda.cmi asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \ - typing/ident.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ + asmcomp/clambda.cmx asmcomp/backend_var.cmx parsing/asttypes.cmi \ asmcomp/printclambda.cmi asmcomp/printclambda.cmi : asmcomp/clambda.cmi -asmcomp/printcmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \ - middle_end/debuginfo.cmi asmcomp/cmm.cmi parsing/asttypes.cmi \ +asmcomp/printcmm.cmo : bytecomp/lambda.cmi middle_end/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/backend_var.cmi parsing/asttypes.cmi \ asmcomp/printcmm.cmi -asmcomp/printcmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \ - middle_end/debuginfo.cmx asmcomp/cmm.cmx parsing/asttypes.cmi \ +asmcomp/printcmm.cmx : bytecomp/lambda.cmx middle_end/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/backend_var.cmx parsing/asttypes.cmi \ asmcomp/printcmm.cmi asmcomp/printcmm.cmi : middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/printcmm.cmi \ @@ -1146,14 +1152,14 @@ asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/printcmm.cmx \ asmcomp/printlinear.cmi : asmcomp/linearize.cmi asmcomp/printmach.cmo : asmcomp/debug/reg_availability_set.cmi \ asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printcmm.cmi asmcomp/mach.cmi \ - asmcomp/interval.cmi typing/ident.cmi middle_end/debuginfo.cmi \ - utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \ - asmcomp/printmach.cmi + asmcomp/interval.cmi middle_end/debuginfo.cmi utils/config.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/backend_var.cmi \ + asmcomp/arch.cmo asmcomp/printmach.cmi asmcomp/printmach.cmx : asmcomp/debug/reg_availability_set.cmx \ asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx asmcomp/mach.cmx \ - asmcomp/interval.cmx typing/ident.cmx middle_end/debuginfo.cmx \ - utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \ - asmcomp/printmach.cmi + asmcomp/interval.cmx middle_end/debuginfo.cmx utils/config.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/backend_var.cmx \ + asmcomp/arch.cmx asmcomp/printmach.cmi asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/proc.cmo : asmcomp/x86_proc.cmi asmcomp/reg.cmi utils/misc.cmi \ asmcomp/mach.cmi utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ @@ -1162,9 +1168,9 @@ asmcomp/proc.cmx : asmcomp/x86_proc.cmx asmcomp/reg.cmx utils/misc.cmx \ asmcomp/mach.cmx utils/config.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/proc.cmi asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi -asmcomp/reg.cmo : typing/ident.cmi asmcomp/cmm.cmi asmcomp/reg.cmi -asmcomp/reg.cmx : typing/ident.cmx asmcomp/cmm.cmx asmcomp/reg.cmi -asmcomp/reg.cmi : typing/ident.cmi asmcomp/cmm.cmi +asmcomp/reg.cmo : asmcomp/cmm.cmi asmcomp/backend_var.cmi asmcomp/reg.cmi +asmcomp/reg.cmx : asmcomp/cmm.cmx asmcomp/backend_var.cmx asmcomp/reg.cmi +asmcomp/reg.cmi : asmcomp/cmm.cmi asmcomp/backend_var.cmi asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ @@ -1187,16 +1193,17 @@ asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.cmi asmcomp/scheduling.cmi : asmcomp/linearize.cmi asmcomp/selectgen.cmo : bytecomp/simplif.cmi asmcomp/reg.cmi \ asmcomp/proc.cmi utils/numbers.cmi utils/misc.cmi asmcomp/mach.cmi \ - bytecomp/lambda.cmi typing/ident.cmi middle_end/debuginfo.cmi \ - utils/config.cmi asmcomp/cmm.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ - asmcomp/selectgen.cmi + bytecomp/lambda.cmi middle_end/debuginfo.cmi utils/config.cmi \ + asmcomp/cmm.cmi asmcomp/backend_var.cmi parsing/asttypes.cmi \ + asmcomp/arch.cmo asmcomp/selectgen.cmi asmcomp/selectgen.cmx : bytecomp/simplif.cmx asmcomp/reg.cmx \ asmcomp/proc.cmx utils/numbers.cmx utils/misc.cmx asmcomp/mach.cmx \ - bytecomp/lambda.cmx typing/ident.cmx middle_end/debuginfo.cmx \ - utils/config.cmx asmcomp/cmm.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ - asmcomp/selectgen.cmi -asmcomp/selectgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi typing/ident.cmi \ - middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo + bytecomp/lambda.cmx middle_end/debuginfo.cmx utils/config.cmx \ + asmcomp/cmm.cmx asmcomp/backend_var.cmx parsing/asttypes.cmi \ + asmcomp/arch.cmx asmcomp/selectgen.cmi +asmcomp/selectgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/backend_var.cmi \ + asmcomp/arch.cmo asmcomp/selection.cmo : asmcomp/spacetime_profiling.cmi \ asmcomp/selectgen.cmi asmcomp/proc.cmi asmcomp/mach.cmi utils/config.cmi \ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi @@ -1205,13 +1212,15 @@ asmcomp/selection.cmx : asmcomp/spacetime_profiling.cmx \ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/selection.cmi asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/spacetime_profiling.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \ - utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi typing/ident.cmi \ + utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \ middle_end/debuginfo.cmi utils/config.cmi asmcomp/cmm.cmi \ - parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/spacetime_profiling.cmi + asmcomp/backend_var.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ + asmcomp/spacetime_profiling.cmi asmcomp/spacetime_profiling.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \ - utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx typing/ident.cmx \ + utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \ middle_end/debuginfo.cmx utils/config.cmx asmcomp/cmm.cmx \ - parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/spacetime_profiling.cmi + asmcomp/backend_var.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ + asmcomp/spacetime_profiling.cmi asmcomp/spacetime_profiling.cmi : asmcomp/selectgen.cmi asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/spill.cmi @@ -1224,10 +1233,10 @@ asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/split.cmi asmcomp/split.cmi : asmcomp/mach.cmi asmcomp/strmatch.cmo : parsing/location.cmi bytecomp/lambda.cmi \ - typing/ident.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/backend_var.cmi \ parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/strmatch.cmi asmcomp/strmatch.cmx : parsing/location.cmx bytecomp/lambda.cmx \ - typing/ident.cmx middle_end/debuginfo.cmx asmcomp/cmm.cmx \ + middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/backend_var.cmx \ parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/strmatch.cmi asmcomp/strmatch.cmi : parsing/location.cmi middle_end/debuginfo.cmi \ asmcomp/cmm.cmi @@ -1259,12 +1268,12 @@ asmcomp/traverse_for_exported_symbols.cmi : \ middle_end/base_types/closure_id.cmi asmcomp/un_anf.cmo : bytecomp/semantics_of_primitives.cmi \ asmcomp/printclambda.cmi utils/misc.cmi bytecomp/lambda.cmi \ - typing/ident.cmi middle_end/debuginfo.cmi utils/clflags.cmi \ - asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/un_anf.cmi + middle_end/debuginfo.cmi utils/clflags.cmi asmcomp/clambda.cmi \ + asmcomp/backend_var.cmi parsing/asttypes.cmi asmcomp/un_anf.cmi asmcomp/un_anf.cmx : bytecomp/semantics_of_primitives.cmx \ asmcomp/printclambda.cmx utils/misc.cmx bytecomp/lambda.cmx \ - typing/ident.cmx middle_end/debuginfo.cmx utils/clflags.cmx \ - asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/un_anf.cmi + middle_end/debuginfo.cmx utils/clflags.cmx asmcomp/clambda.cmx \ + asmcomp/backend_var.cmx parsing/asttypes.cmi asmcomp/un_anf.cmi asmcomp/un_anf.cmi : asmcomp/clambda.cmi asmcomp/x86_ast.cmi : asmcomp/x86_dsl.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ @@ -2289,26 +2298,27 @@ middle_end/base_types/variable.cmi : middle_end/internal_variable_names.cmi \ middle_end/base_types/compilation_unit.cmi asmcomp/debug/available_regs.cmo : asmcomp/debug/reg_with_debug_info.cmi \ asmcomp/debug/reg_availability_set.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ - asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi \ - utils/clflags.cmi asmcomp/debug/available_regs.cmi + asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi utils/clflags.cmi \ + asmcomp/backend_var.cmi asmcomp/debug/available_regs.cmi asmcomp/debug/available_regs.cmx : asmcomp/debug/reg_with_debug_info.cmx \ asmcomp/debug/reg_availability_set.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ - asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \ - utils/clflags.cmx asmcomp/debug/available_regs.cmi + asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx utils/clflags.cmx \ + asmcomp/backend_var.cmx asmcomp/debug/available_regs.cmi asmcomp/debug/available_regs.cmi : asmcomp/mach.cmi asmcomp/debug/reg_availability_set.cmo : \ - asmcomp/debug/reg_with_debug_info.cmi typing/ident.cmi \ + asmcomp/debug/reg_with_debug_info.cmi asmcomp/backend_var.cmi \ asmcomp/debug/reg_availability_set.cmi asmcomp/debug/reg_availability_set.cmx : \ - asmcomp/debug/reg_with_debug_info.cmx typing/ident.cmx \ + asmcomp/debug/reg_with_debug_info.cmx asmcomp/backend_var.cmx \ asmcomp/debug/reg_availability_set.cmi asmcomp/debug/reg_availability_set.cmi : \ asmcomp/debug/reg_with_debug_info.cmi asmcomp/reg.cmi -asmcomp/debug/reg_with_debug_info.cmo : asmcomp/reg.cmi typing/ident.cmi \ - asmcomp/debug/reg_with_debug_info.cmi -asmcomp/debug/reg_with_debug_info.cmx : asmcomp/reg.cmx typing/ident.cmx \ - asmcomp/debug/reg_with_debug_info.cmi -asmcomp/debug/reg_with_debug_info.cmi : asmcomp/reg.cmi typing/ident.cmi +asmcomp/debug/reg_with_debug_info.cmo : asmcomp/reg.cmi \ + asmcomp/backend_var.cmi asmcomp/debug/reg_with_debug_info.cmi +asmcomp/debug/reg_with_debug_info.cmx : asmcomp/reg.cmx \ + asmcomp/backend_var.cmx asmcomp/debug/reg_with_debug_info.cmi +asmcomp/debug/reg_with_debug_info.cmi : asmcomp/reg.cmi \ + asmcomp/backend_var.cmi driver/compdynlink.cmi : driver/compenv.cmo : utils/warnings.cmi utils/profile.cmi utils/misc.cmi \ parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \ diff --git a/Changes b/Changes index ffd197d19..318f21a52 100644 --- a/Changes +++ b/Changes @@ -403,6 +403,10 @@ Working version - GPR#2055: Add [Linearize.Lprologue]. (Mark Shinwell, review by Pierre Chambart) +- GPR#2056: Use [Backend_var] rather than [Ident] from [Clambda] onwards; + use [Backend_var.With_provenance] for variables in binding position. + (Mark Shinwell, review by Pierre Chambart) + ### Bug fixes: - MPR#7847, GPR#2019: Fix an infinite loop that could occur when the diff --git a/Makefile b/Makefile index 7e43375ea..d6986cdb3 100644 --- a/Makefile +++ b/Makefile @@ -146,6 +146,7 @@ endif ASMCOMP=\ $(ARCH_SPECIFIC_ASMCOMP) \ asmcomp/arch.cmo \ + asmcomp/backend_var.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/debug/reg_with_debug_info.cmo \ asmcomp/debug/reg_availability_set.cmo \ diff --git a/asmcomp/afl_instrument.ml b/asmcomp/afl_instrument.ml index 8011a316a..0606dd666 100644 --- a/asmcomp/afl_instrument.ml +++ b/asmcomp/afl_instrument.ml @@ -17,6 +17,9 @@ open Lambda open Cmm +module V = Backend_var +module VP = Backend_var.With_provenance + let afl_area_ptr = Cconst_symbol "caml_afl_area_ptr" let afl_prev_loc = Cconst_symbol "caml_afl_prev_loc" let afl_map_size = 1 lsl 16 @@ -35,20 +38,21 @@ let rec with_afl_logging b = docs/technical_details.txt in afl-fuzz source for for a full description of what's going on. *) let cur_location = Random.int afl_map_size in - let cur_pos = Ident.create_local "pos" in - let afl_area = Ident.create_local "shared_mem" in + let cur_pos = V.create_local "pos" in + let afl_area = V.create_local "shared_mem" in let op oper args = Cop (oper, args, Debuginfo.none) in - Clet(afl_area, op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr], - Clet(cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable)) - [afl_prev_loc]; Cconst_int cur_location], - Csequence( - op (Cstore(Byte_unsigned, Assignment)) - [op Cadda [Cvar afl_area; Cvar cur_pos]; - op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable)) - [op Cadda [Cvar afl_area; Cvar cur_pos]]; - Cconst_int 1]], - op (Cstore(Word_int, Assignment)) - [afl_prev_loc; Cconst_int (cur_location lsr 1)]))) in + Clet(VP.create afl_area, + op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr], + Clet(VP.create cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable)) + [afl_prev_loc]; Cconst_int cur_location], + Csequence( + op (Cstore(Byte_unsigned, Assignment)) + [op Cadda [Cvar afl_area; Cvar cur_pos]; + op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable)) + [op Cadda [Cvar afl_area; Cvar cur_pos]]; + Cconst_int 1]], + op (Cstore(Word_int, Assignment)) + [afl_prev_loc; Cconst_int (cur_location lsr 1)]))) in Csequence(instrumentation, instrument b) and instrument = function diff --git a/asmcomp/backend_var.ml b/asmcomp/backend_var.ml new file mode 100644 index 000000000..39af7f606 --- /dev/null +++ b/asmcomp/backend_var.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2018 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +include Ident + +type backend_var = t + +module Provenance = struct + type t = { + module_path : Path.t; + location : Debuginfo.t; + original_ident : Ident.t; + } + + let print ppf { module_path; location; original_ident; } = + Format.fprintf ppf "@[(\ + @[(module_path@ %a)@]@ \ + @[(location@ %a)@]@ \ + @[(original_ident@ %a)@]\ + )@]" + Path.print module_path + Debuginfo.print_compact location + Ident.print original_ident + + let create ~module_path ~location ~original_ident = + { module_path; + location; + original_ident; + } + + let module_path t = t.module_path + let location t = t.location + let original_ident t = t.original_ident +end + +module With_provenance = struct + type t = + | Without_provenance of backend_var + | With_provenance of { + var : backend_var; + provenance : Provenance.t; + } + + let create ?provenance var = + match provenance with + | None -> Without_provenance var + | Some provenance -> With_provenance { var; provenance; } + + let var t = + match t with + | Without_provenance var + | With_provenance { var; provenance = _; } -> var + + let provenance t = + match t with + | Without_provenance _ -> None + | With_provenance { var = _; provenance; } -> Some provenance + + let name t = name (var t) + + let rename t = + let var = rename (var t) in + match provenance t with + | None -> Without_provenance var + | Some provenance -> With_provenance { var; provenance; } + + let print ppf t = + match provenance t with + | None -> print ppf (var t) + | Some provenance -> + Format.fprintf ppf "%a[%a]" + print (var t) + Provenance.print provenance +end diff --git a/asmcomp/backend_var.mli b/asmcomp/backend_var.mli new file mode 100644 index 000000000..f236be1e4 --- /dev/null +++ b/asmcomp/backend_var.mli @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2018 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Variables used in the backend, optionally equipped with "provenance" + information, used for the emission of debugging information. *) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +include module type of struct include Ident end + +type backend_var = t + +module Provenance : sig + type t + + val create + : module_path:Path.t + -> location:Debuginfo.t + -> original_ident:Ident.t + -> t + + val module_path : t -> Path.t + val location : t -> Debuginfo.t + val original_ident : t -> Ident.t + + val print : Format.formatter -> t -> unit +end + +module With_provenance : sig + (** Values of type [t] should be used for variables in binding position. *) + type t + + val print : Format.formatter -> t -> unit + + val create : ?provenance:Provenance.t -> backend_var -> t + + val var : t -> backend_var + val provenance : t -> Provenance.t option + + val name : t -> string + + val rename : t -> t +end diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 7fdec7d36..88b729a31 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -37,35 +37,37 @@ and uconstant = | Uconst_ptr of int and ulambda = - Uvar of Ident.t + Uvar of Backend_var.t | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int - | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda - | Uletrec of (Ident.t * ulambda) list * ulambda + | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t + * ulambda * ulambda + | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch * Debuginfo.t | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list - | Ucatch of int * Ident.t list * ulambda * ulambda - | Utrywith of ulambda * Ident.t * ulambda + | Ucatch of int * Backend_var.With_provenance.t list * ulambda * ulambda + | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda | Uifthenelse of ulambda * ulambda * ulambda | Usequence of ulambda * ulambda | Uwhile of ulambda * ulambda - | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda - | Uassign of Ident.t * ulambda + | Ufor of Backend_var.With_provenance.t * ulambda * ulambda + * direction_flag * ulambda + | Uassign of Backend_var.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t | Uunreachable and ufunction = { label : function_label; arity : int; - params : Ident.t list; + params : Backend_var.With_provenance.t list; body : ulambda; dbg : Debuginfo.t; - env : Ident.t option; + env : Backend_var.t option; } and ulambda_switch = @@ -80,7 +82,7 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; mutable fun_float_const_prop: bool (* Can propagate FP consts *) } diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index e4db85a06..c11593beb 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -37,35 +37,37 @@ and uconstant = | Uconst_ptr of int and ulambda = - Uvar of Ident.t + Uvar of Backend_var.t | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int - | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda - | Uletrec of (Ident.t * ulambda) list * ulambda + | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t + * ulambda * ulambda + | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch * Debuginfo.t | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list - | Ucatch of int * Ident.t list * ulambda * ulambda - | Utrywith of ulambda * Ident.t * ulambda + | Ucatch of int * Backend_var.With_provenance.t list * ulambda * ulambda + | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda | Uifthenelse of ulambda * ulambda * ulambda | Usequence of ulambda * ulambda | Uwhile of ulambda * ulambda - | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda - | Uassign of Ident.t * ulambda + | Ufor of Backend_var.With_provenance.t * ulambda * ulambda + * direction_flag * ulambda + | Uassign of Backend_var.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t | Uunreachable and ufunction = { label : function_label; arity : int; - params : Ident.t list; + params : Backend_var.With_provenance.t list; body : ulambda; dbg : Debuginfo.t; - env : Ident.t option; + env : Backend_var.t option; } and ulambda_switch = @@ -80,7 +82,7 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; mutable fun_float_const_prop: bool (* Can propagate FP consts *) } diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 3ef15a2bd..f84cf6f5e 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -32,6 +32,9 @@ module Storer = let compare_key = Stdlib.compare end) +module V = Backend_var +module VP = Backend_var.With_provenance + (* Auxiliaries for compiling functions *) let rec split_list n l = @@ -42,10 +45,11 @@ let rec split_list n l = end let rec build_closure_env env_param pos = function - [] -> Ident.Map.empty + [] -> V.Map.empty | id :: rem -> - Ident.Map.add id (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none)) - (build_closure_env env_param (pos+1) rem) + V.Map.add id + (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none)) + (build_closure_env env_param (pos+1) rem) (* Auxiliary for accessing globals. We change the name of the global to the name of the corresponding asm symbol. This is done here @@ -53,7 +57,7 @@ let rec build_closure_env env_param pos = function contain the right names if the -for-pack option is active. *) let getglobal dbg id = - Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)), + Uprim(Pgetglobal (V.create_persistent (Compilenv.symbol_for_global id)), [], dbg) (* Check if a variable occurs in a [clambda] term. *) @@ -547,7 +551,7 @@ let subst_debuginfo loc dbg = let rec substitute loc fpc sb rn ulam = match ulam with Uvar v -> - begin try Ident.Map.find v sb with Not_found -> ulam end + begin try V.Map.find v sb with Not_found -> ulam end | Uconst _ -> ulam | Udirect_apply(lbl, args, dbg) -> let dbg = subst_debuginfo loc dbg in @@ -568,16 +572,20 @@ let rec substitute loc fpc sb rn ulam = Uclosure(defs, List.map (substitute loc fpc sb rn) env) | Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb rn u, ofs) | Ulet(str, kind, id, u1, u2) -> - let id' = Ident.rename id in + let id' = VP.rename id in Ulet(str, kind, id', substitute loc fpc sb rn u1, - substitute loc fpc (Ident.Map.add id (Uvar id') sb) rn u2) + substitute loc fpc + (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) | Uletrec(bindings, body) -> let bindings1 = - List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in + List.map (fun (id, rhs) -> + (VP.var id, VP.rename id, rhs)) bindings + in let sb' = - List.fold_right - (fun (id, id', _) s -> Ident.Map.add id (Uvar id') s) - bindings1 sb in + List.fold_right (fun (id, id', _) s -> + V.Map.add id (Uvar (VP.var id')) s) + bindings1 sb + in Uletrec( List.map (fun (_id, id', rhs) -> (id', substitute loc fpc sb' rn rhs)) @@ -640,18 +648,19 @@ let rec substitute loc fpc sb rn ulam = let new_nfail = next_raise_count () in new_nfail, Some (Int.Map.add nfail new_nfail rn) | None -> nfail, rn in - let ids' = List.map Ident.rename ids in + let ids' = List.map VP.rename ids in let sb' = List.fold_right2 - (fun id id' s -> Ident.Map.add id (Uvar id') s) + (fun id id' s -> V.Map.add (VP.var id) (Uvar (VP.var id')) s) ids ids' sb in Ucatch(nfail, ids', substitute loc fpc sb rn u1, substitute loc fpc sb' rn u2) | Utrywith(u1, id, u2) -> - let id' = Ident.rename id in + let id' = VP.rename id in Utrywith(substitute loc fpc sb rn u1, id', - substitute loc fpc (Ident.Map.add id (Uvar id') sb) rn u2) + substitute loc fpc + (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) | Uifthenelse(u1, u2, u3) -> begin match substitute loc fpc sb rn u1 with Uconst (Uconst_ptr n) -> @@ -670,13 +679,14 @@ let rec substitute loc fpc sb rn ulam = | Uwhile(u1, u2) -> Uwhile(substitute loc fpc sb rn u1, substitute loc fpc sb rn u2) | Ufor(id, u1, u2, dir, u3) -> - let id' = Ident.rename id in + let id' = VP.rename id in Ufor(id', substitute loc fpc sb rn u1, substitute loc fpc sb rn u2, dir, - substitute loc fpc (Ident.Map.add id (Uvar id') sb) rn u3) + substitute loc fpc + (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3) | Uassign(id, u) -> let id' = try - match Ident.Map.find id sb with Uvar i -> i | _ -> assert false + match V.Map.find id sb with Uvar i -> i | _ -> assert false with Not_found -> id in Uassign(id', substitute loc fpc sb rn u) @@ -702,19 +712,22 @@ let rec bind_params_rec loc fpc subst params args body = ([], []) -> substitute loc fpc subst (Some Int.Map.empty) body | (p1 :: pl, a1 :: al) -> if is_simple_argument a1 then - bind_params_rec loc fpc (Ident.Map.add p1 a1 subst) pl al body + bind_params_rec loc fpc (V.Map.add (VP.var p1) a1 subst) + pl al body else begin - let p1' = Ident.rename p1 in + let p1' = VP.rename p1 in let u1, u2 = - match Ident.name p1, a1 with + match VP.name p1, a1 with | "*opt*", Uprim(Pmakeblock(0, Immutable, kind), [a], dbg) -> - a, Uprim(Pmakeblock(0, Immutable, kind), [Uvar p1'], dbg) + a, Uprim(Pmakeblock(0, Immutable, kind), [Uvar (VP.var p1')], dbg) | _ -> - a1, Uvar p1' + a1, Uvar (VP.var p1') in let body' = - bind_params_rec loc fpc (Ident.Map.add p1 u2 subst) pl al body in - if occurs_var p1 body then Ulet(Immutable, Pgenval, p1', u1, body') + bind_params_rec loc fpc (V.Map.add (VP.var p1) u2 subst) + pl al body in + if occurs_var (VP.var p1) body then + Ulet(Immutable, Pgenval, p1', u1, body') else if no_effects a1 then body' else Usequence(a1, body') end @@ -723,7 +736,7 @@ let rec bind_params_rec loc fpc subst params args body = let bind_params loc fpc params args body = (* Reverse parameters and arguments to preserve right-to-left evaluation order (PR#2910). *) - bind_params_rec loc fpc Ident.Map.empty (List.rev params) (List.rev args) body + bind_params_rec loc fpc V.Map.empty (List.rev params) (List.rev args) body (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) @@ -784,7 +797,7 @@ let check_constant_result lam ulam approx = | Uprim(Pfield _, [Uprim(Pgetglobal _, _, _)], _) -> (ulam, approx) | _ -> let glb = - Uprim(Pgetglobal (Ident.create_persistent id), [], Debuginfo.none) + Uprim(Pgetglobal (V.create_persistent id), [], Debuginfo.none) in Uprim(Pfield i, [glb], Debuginfo.none), approx end @@ -815,11 +828,11 @@ let excessive_function_nesting_depth = 5 exception NotClosed let close_approx_var fenv cenv id = - let approx = try Ident.Map.find id fenv with Not_found -> Value_unknown in + let approx = try V.Map.find id fenv with Not_found -> Value_unknown in match approx with Value_const c -> make_const c | approx -> - let subst = try Ident.Map.find id cenv with Not_found -> Uvar id in + let subst = try V.Map.find id cenv with Not_found -> Uvar id in (subst, approx) let close_var fenv cenv id = @@ -884,23 +897,23 @@ let rec close fenv cenv = function | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs) when nargs < fundesc.fun_arity -> let first_args = List.map (fun arg -> - (Ident.create_local "arg", arg) ) uargs in + (V.create_local "arg", arg) ) uargs in let final_args = Array.to_list (Array.init (fundesc.fun_arity - nargs) - (fun _ -> Ident.create_local "arg")) in + (fun _ -> V.create_local "arg")) in let rec iter args body = match args with [] -> body | (arg1, arg2) :: args -> iter args - (Ulet (Immutable, Pgenval, arg1, arg2, body)) + (Ulet (Immutable, Pgenval, VP.create arg1, arg2, body)) in let internal_args = (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args) @ (List.map (fun arg -> Lvar arg ) final_args) in - let funct_var = Ident.create_local "funct" in - let fenv = Ident.Map.add funct_var fapprox fenv in + let funct_var = V.create_local "funct" in + let fenv = V.Map.add funct_var fapprox fenv in let (new_fun, approx) = close fenv cenv (Lfunction{ kind = Curried; @@ -916,14 +929,14 @@ let rec close fenv cenv = function in let new_fun = iter first_args - (Ulet (Immutable, Pgenval, funct_var, ufunct, new_fun)) + (Ulet (Immutable, Pgenval, VP.create funct_var, ufunct, new_fun)) in warning_if_forced_inline ~loc ~attribute "Partial application"; (new_fun, approx) | ((ufunct, Value_closure(fundesc, _approx_res)), uargs) when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> - let args = List.map (fun arg -> Ident.create_local "arg",arg) uargs in + let args = List.map (fun arg -> V.create_local "arg", arg) uargs in let (first_args, rem_args) = split_list fundesc.fun_arity args in let first_args = List.map (fun (id, _) -> Uvar id) first_args in let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in @@ -936,7 +949,7 @@ let rec close fenv cenv = function in let result = List.fold_left (fun body (id, defining_expr) -> - Ulet (Immutable, Pgenval, id, defining_expr, body)) + Ulet (Immutable, Pgenval, VP.create id, defining_expr, body)) body args in @@ -957,13 +970,13 @@ let rec close fenv cenv = function begin match (str, alam) with (Variable, _) -> let (ubody, abody) = close fenv cenv body in - (Ulet(Mutable, kind, id, ulam, ubody), abody) + (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody) | (_, Value_const _) when str = Alias || is_pure lam -> - close (Ident.Map.add id alam fenv) cenv body + close (V.Map.add id alam fenv) cenv body | (_, _) -> - let (ubody, abody) = close (Ident.Map.add id alam fenv) cenv body in - (Ulet(Immutable, kind, id, ulam, ubody), abody) + let (ubody, abody) = close (V.Map.add id alam fenv) cenv body in + (Ulet(Immutable, kind, VP.create id, ulam, ubody), abody) end | Lletrec(defs, body) -> if List.for_all @@ -972,18 +985,18 @@ let rec close fenv cenv = function then begin (* Simple case: only function definitions *) let (clos, infos) = close_functions fenv cenv defs in - let clos_ident = Ident.create_local "clos" in + let clos_ident = V.create_local "clos" in let fenv_body = List.fold_right - (fun (id, _pos, approx) fenv -> Ident.Map.add id approx fenv) + (fun (id, _pos, approx) fenv -> V.Map.add id approx fenv) infos fenv in let (ubody, approx) = close fenv_body cenv body in let sb = List.fold_right (fun (id, pos, _approx) sb -> - Ident.Map.add id (Uoffset(Uvar clos_ident, pos)) sb) - infos Ident.Map.empty in - (Ulet(Immutable, Pgenval, clos_ident, clos, + V.Map.add id (Uoffset(Uvar clos_ident, pos)) sb) + infos V.Map.empty in + (Ulet(Immutable, Pgenval, VP.create clos_ident, clos, substitute Location.none !Clflags.float_const_prop sb None ubody), approx) end else begin @@ -993,7 +1006,7 @@ let rec close fenv cenv = function | (id, lam) :: rem -> let (udefs, fenv_body) = clos_defs rem in let (ulam, approx) = close_named fenv cenv id lam in - ((id, ulam) :: udefs, Ident.Map.add id approx fenv_body) in + ((VP.create id, ulam) :: udefs, V.Map.add id approx fenv_body) in let (udefs, fenv_body) = clos_defs defs in let (ubody, approx) = close fenv_body cenv body in (Uletrec(udefs, ubody), approx) @@ -1083,11 +1096,12 @@ let rec close fenv cenv = function | Lstaticcatch(body, (i, vars), handler) -> let (ubody, _) = close fenv cenv body in let (uhandler, _) = close fenv cenv handler in + let vars = List.map (fun var -> VP.create var) vars in (Ucatch(i, vars, ubody, uhandler), Value_unknown) | Ltrywith(body, id, handler) -> let (ubody, _) = close fenv cenv body in let (uhandler, _) = close fenv cenv handler in - (Utrywith(ubody, id, uhandler), Value_unknown) + (Utrywith(ubody, VP.create id, uhandler), Value_unknown) | Lifthenelse(arg, ifso, ifnot) -> begin match close fenv cenv arg with (uarg, Value_const (Uconst_ptr n)) -> @@ -1110,7 +1124,7 @@ let rec close fenv cenv = function let (ulo, _) = close fenv cenv lo in let (uhi, _) = close fenv cenv hi in let (ubody, _) = close fenv cenv body in - (Ufor(id, ulo, uhi, dir, ubody), Value_unknown) + (Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown) | Lassign(id, lam) -> let (ulam, _) = close fenv cenv lam in (Uassign(id, ulam), Value_unknown) @@ -1162,7 +1176,7 @@ and close_functions fenv cenv fun_defs = !function_nesting_depth < excessive_function_nesting_depth in (* Determine the free variables of the functions *) let fv = - Ident.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in + V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in (* Build the function descriptors for the functions. Initially all functions are assumed not to need their environment parameter. *) @@ -1170,7 +1184,7 @@ and close_functions fenv cenv fun_defs = List.map (function (id, Lfunction{kind; params; body; loc}) -> - let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in + let label = Compilenv.make_symbol (Some (V.unique_name id)) in let arity = List.length params in let fundesc = {fun_label = label; @@ -1186,7 +1200,7 @@ and close_functions fenv cenv fun_defs = let fenv_rec = List.fold_right (fun (id, _params, _body, fundesc, _dbg) fenv -> - Ident.Map.add id (Value_closure(fundesc, Value_unknown)) fenv) + V.Map.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 @@ -1203,13 +1217,13 @@ and close_functions fenv cenv fun_defs = let useless_env = ref initially_closed in (* Translate each function definition *) let clos_fundef (id, params, body, fundesc, dbg) env_pos = - let env_param = Ident.create_local "env" in + let env_param = V.create_local "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, _dbg) pos env -> - Ident.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env) + V.Map.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 if !useless_env && occurs_var env_param ubody then raise NotClosed; @@ -1218,7 +1232,7 @@ and close_functions fenv cenv fun_defs = { label = fundesc.fun_label; arity = fundesc.fun_arity; - params = fun_params; + params = List.map (fun var -> VP.create var) fun_params; body = ubody; dbg; env = Some env_param; @@ -1228,7 +1242,7 @@ and close_functions fenv cenv fun_defs = their wrapper functions) to be inlined *) let n = List.fold_left - (fun n id -> n + if Ident.name id = "*opt*" then 8 else 1) + (fun n id -> n + if V.name id = "*opt*" then 8 else 1) 0 fun_params in @@ -1244,6 +1258,7 @@ and close_functions fenv cenv fun_defs = | Never_inline -> min_int | Unroll _ -> assert false in + let fun_params = List.map (fun var -> VP.create var) fun_params in if lambda_smaller ubody threshold then fundesc.fun_inline <- Some(fun_params, ubody); @@ -1405,7 +1420,7 @@ let intro size lam = let id = Compilenv.make_symbol None in global_approx := Array.init size (fun i -> Value_global_field (id, i)); Compilenv.set_global_approx(Value_tuple !global_approx); - let (ulam, _approx) = close Ident.Map.empty Ident.Map.empty lam in + let (ulam, _approx) = close V.Map.empty V.Map.empty lam in let opaque = !Clflags.opaque || Env.is_imported_opaque (Compilenv.current_unit_name ()) diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index b2c1118ab..48c4f5445 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -157,9 +157,9 @@ type expression = | Cconst_pointer of int | Cconst_natpointer of nativeint | Cblockheader of nativeint * Debuginfo.t - | Cvar of Ident.t - | Clet of Ident.t * expression * expression - | Cassign of Ident.t * expression + | Cvar of Backend_var.t + | Clet of Backend_var.With_provenance.t * expression * expression + | Cassign of Backend_var.t * expression | Ctuple of expression list | Cop of operation * expression list * Debuginfo.t | Csequence of expression * expression @@ -167,10 +167,12 @@ type expression = | Cswitch of expression * int array * expression array * Debuginfo.t | Cloop of expression | Ccatch of - rec_flag * (int * (Ident.t * machtype) list * expression) list - * expression + rec_flag + * (int * (Backend_var.With_provenance.t * machtype) list + * expression) list + * expression | Cexit of int * expression list - | Ctrywith of expression * Ident.t * expression + | Ctrywith of expression * Backend_var.With_provenance.t * expression type codegen_option = | Reduce_code_size @@ -178,7 +180,7 @@ type codegen_option = type fundecl = { fun_name: string; - fun_args: (Ident.t * machtype) list; + fun_args: (Backend_var.With_provenance.t * machtype) list; fun_body: expression; fun_codegen_options : codegen_option list; fun_dbg : Debuginfo.t; diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 6b3b446eb..60c7808f7 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -137,9 +137,9 @@ and expression = | Cconst_pointer of int | Cconst_natpointer of nativeint | Cblockheader of nativeint * Debuginfo.t - | Cvar of Ident.t - | Clet of Ident.t * expression * expression - | Cassign of Ident.t * expression + | Cvar of Backend_var.t + | Clet of Backend_var.With_provenance.t * expression * expression + | Cassign of Backend_var.t * expression | Ctuple of expression list | Cop of operation * expression list * Debuginfo.t | Csequence of expression * expression @@ -147,10 +147,12 @@ and expression = | Cswitch of expression * int array * expression array * Debuginfo.t | Cloop of expression | Ccatch of - rec_flag * (int * (Ident.t * machtype) list * expression) list - * expression + rec_flag + * (int * (Backend_var.With_provenance.t * machtype) list + * expression) list + * expression | Cexit of int * expression list - | Ctrywith of expression * Ident.t * expression + | Ctrywith of expression * Backend_var.With_provenance.t * expression type codegen_option = | Reduce_code_size @@ -158,7 +160,7 @@ type codegen_option = type fundecl = { fun_name: string; - fun_args: (Ident.t * machtype) list; + fun_args: (Backend_var.With_provenance.t * machtype) list; fun_body: expression; fun_codegen_options : codegen_option list; fun_dbg : Debuginfo.t; @@ -183,6 +185,8 @@ type phrase = | Cdata of data_item list val ccatch : - int * (Ident.t * machtype) list * expression * expression -> expression + int * (Backend_var.With_provenance.t * machtype) list + * expression * expression + -> expression val reset : unit -> unit diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 5fcd1e12a..2048cade2 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -24,7 +24,10 @@ open Lambda open Clambda open Cmm open Cmx_format + module String = Misc.Stdlib.String +module V = Backend_var +module VP = Backend_var.With_provenance (* Environments used for translation to Cmm. *) @@ -33,28 +36,28 @@ type boxed_number = | Boxed_integer of boxed_integer * Debuginfo.t type env = { - unboxed_ids : (Ident.t * boxed_number) Ident.tbl; - environment_param : Ident.t option; + unboxed_ids : (V.t * boxed_number) V.tbl; + environment_param : V.t option; } let empty_env = { - unboxed_ids =Ident.empty; + unboxed_ids =V.empty; environment_param = None; } let create_env ~environment_param = - { unboxed_ids = Ident.empty; + { unboxed_ids = V.empty; environment_param; } let is_unboxed_id id env = - try Some (Ident.find_same id env.unboxed_ids) + try Some (V.find_same id env.unboxed_ids) with Not_found -> None let add_unboxed_id id unboxed_id bn env = { env with - unboxed_ids = Ident.add id (unboxed_id, bn) env.unboxed_ids; + unboxed_ids = V.add id (unboxed_id, bn) env.unboxed_ids; } (* Local binding of complex expressions *) @@ -64,7 +67,7 @@ let bind name arg fn = Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ | Cblockheader _ -> fn arg - | _ -> let id = Ident.create_local name in Clet(id, arg, fn (Cvar id)) + | _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id)) let bind_load name arg fn = match arg with @@ -76,7 +79,7 @@ let bind_nonvar name arg fn = Cconst_int _ | Cconst_natint _ | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ | Cblockheader _ -> fn arg - | _ -> let id = Ident.create_local name in Clet(id, arg, fn (Cvar id)) + | _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id)) let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 (* cf. runtime/caml/gc.h *) @@ -603,7 +606,7 @@ let get_field env ptr n dbg = match ptr with | Cvar ptr -> (* Loads from the current function's closure are immutable. *) - if Ident.same environment_param ptr then Immutable + if V.same environment_param ptr then Immutable else Mutable | _ -> Mutable in @@ -728,8 +731,8 @@ let float_array_set arr ofs newval dbg = let string_length exp dbg = bind "str" exp (fun str -> - let tmp_var = Ident.create_local "tmp" in - Clet(tmp_var, + let tmp_var = V.create_local "tmp" in + Clet(VP.create tmp_var, Cop(Csubi, [Cop(Clsl, [get_size str dbg; @@ -770,12 +773,12 @@ let make_alloc_generic set_fn dbg tag wordsize args = if wordsize <= Config.max_young_wosize then Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg) else begin - let id = Ident.create_local "alloc" in + let id = V.create_local "alloc" in let rec fill_fields idx = function [] -> Cvar id | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1 dbg, fill_fields (idx + 2) el) in - Clet(id, + Clet(VP.create id, Cop(Cextcall("caml_alloc", typ_val, true, None), [Cconst_int wordsize; Cconst_int tag], dbg), fill_fields 1 args) @@ -827,15 +830,15 @@ type rhs_kind = ;; let rec expr_size env = function | Uvar id -> - begin try Ident.find_same id env with Not_found -> RHS_nonrec end + begin try V.find_same id env with Not_found -> RHS_nonrec end | Uclosure(fundecls, clos_vars) -> RHS_block (fundecls_size fundecls + List.length clos_vars) | Ulet(_str, _kind, id, exp, body) -> - expr_size (Ident.add id (expr_size env exp) env) body + expr_size (V.add (VP.var id) (expr_size env exp) env) body | Uletrec(bindings, body) -> let env = List.fold_right - (fun (id, exp) env -> Ident.add id (expr_size env exp) env) + (fun (id, exp) env -> V.add (VP.var id) (expr_size env exp) env) bindings env in expr_size env body @@ -1793,7 +1796,7 @@ let rec transl env e = | Uprim(prim, args, dbg) -> begin match (simplif_primitive prim, args) with (Pgetglobal id, []) -> - Cconst_symbol (Ident.name id) + Cconst_symbol (V.name id) | (Pmakeblock _, []) -> assert false | (Pmakeblock(tag, _mut, _kind), args) -> @@ -1925,7 +1928,7 @@ let rec transl env e = let tst = match dir with Upto -> Cgt | Downto -> Clt in let inc = match dir with Upto -> Caddi | Downto -> Csubi in let raise_num = next_raise_count () in - let id_prev = Ident.rename id in + let id_prev = VP.rename id in return_unit (Clet (id, transl env low, @@ -1933,18 +1936,18 @@ let rec transl env e = ccatch (raise_num, [], Cifthenelse - (Cop(Ccmpi tst, [Cvar id; high], dbg), + (Cop(Ccmpi tst, [Cvar (VP.var id); high], dbg), Cexit (raise_num, []), Cloop (Csequence (remove_unit(transl env body), - Clet(id_prev, Cvar id, + Clet(id_prev, Cvar (VP.var id), Csequence - (Cassign(id, - Cop(inc, [Cvar id; Cconst_int 2], + (Cassign(VP.var id, + Cop(inc, [Cvar (VP.var id); Cconst_int 2], dbg)), Cifthenelse - (Cop(Ccmpi Ceq, [Cvar id_prev; high], + (Cop(Ccmpi Ceq, [Cvar (VP.var id_prev); high], dbg), Cexit (raise_num,[]), Ctuple [])))))), Ctuple [])))) @@ -2162,7 +2165,7 @@ and transl_prim_2 env p arg1 arg2 dbg = let dbg' = Debuginfo.none in transl_sequand env arg1 dbg arg2 dbg' Then_true_else_false (Cconst_pointer 3) (Cconst_pointer 1) - (* let id = Ident.create "res1" in + (* let id = V.create_local "res1" in Clet(id, transl env arg1, Cifthenelse(test_bool dbg (Cvar id), transl env arg2, Cvar id)) *) | Psequor -> @@ -2664,9 +2667,9 @@ and transl_let env str kind id exp body = there may be constant closures inside that need lifting out. *) Clet(id, transl env exp, transl env body) | Boxed (boxed_number, _false) -> - let unboxed_id = Ident.create_local (Ident.name id) in - Clet(unboxed_id, transl_unbox_number dbg env boxed_number exp, - transl (add_unboxed_id id unboxed_id boxed_number env) body) + let unboxed_id = V.create_local (VP.name id) in + Clet(VP.create unboxed_id, transl_unbox_number dbg env boxed_number exp, + transl (add_unboxed_id (VP.var id) unboxed_id boxed_number env) body) and make_catch ncatch body handler = match body with | Cexit (nexit,[]) when nexit=ncatch -> handler @@ -2787,7 +2790,7 @@ and transl_switch loc env arg index cases = match Array.length cases with and transl_letrec env bindings cont = let dbg = Debuginfo.none in let bsz = - List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp)) + List.map (fun (id, exp) -> (id, exp, expr_size V.empty exp)) bindings in let op_alloc prim sz = @@ -2813,7 +2816,7 @@ and transl_letrec env bindings cont = | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> let op = Cop(Cextcall("caml_update_dummy", typ_void, false, None), - [Cvar id; transl env exp], dbg) in + [Cvar (VP.var id); transl env exp], dbg) in Csequence(op, fill_blocks rem) | (_id, _exp, RHS_nonrec) :: rem -> fill_blocks rem @@ -3127,18 +3130,18 @@ CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) let cache_public_method meths tag cache dbg = let raise_num = next_raise_count () in - let li = Ident.create_local "li" and hi = Ident.create_local "hi" - and mi = Ident.create_local "mi" and tagged = Ident.create_local "tagged" in + let li = V.create_local "li" and hi = V.create_local "hi" + and mi = V.create_local "mi" and tagged = V.create_local "tagged" in Clet ( - li, Cconst_int 3, + VP.create li, Cconst_int 3, Clet ( - hi, Cop(Cload (Word_int, Mutable), [meths], dbg), + VP.create hi, Cop(Cload (Word_int, Mutable), [meths], dbg), Csequence( ccatch (raise_num, [], Cloop (Clet( - mi, + VP.create mi, Cop(Cor, [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); Cconst_int 1], dbg); @@ -3160,7 +3163,7 @@ let cache_public_method meths tag cache dbg = Ctuple [])))), Ctuple []), Clet ( - tagged, + VP.create tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr dbg; Cconst_int(1 - 3 * size_addr)], dbg), Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg), @@ -3179,17 +3182,17 @@ let cache_public_method meths tag cache dbg = let apply_function_body arity = let dbg = Debuginfo.none in - let arg = Array.make arity (Ident.create_local "arg") in - for i = 1 to arity - 1 do arg.(i) <- Ident.create_local "arg" done; - let clos = Ident.create_local "clos" in + let arg = Array.make arity (V.create_local "arg") in + for i = 1 to arity - 1 do arg.(i) <- V.create_local "arg" done; + let clos = V.create_local "clos" in let env = empty_env in let rec app_fun clos n = if n = arity-1 then Cop(Capply typ_val, [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg) else begin - let newclos = Ident.create_local "clos" in - Clet(newclos, + let newclos = V.create_local "clos" in + Clet(VP.create newclos, Cop(Capply typ_val, [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg), app_fun newclos (n+1)) @@ -3208,27 +3211,26 @@ let apply_function_body arity = let send_function arity = let dbg = Debuginfo.none in let (args, clos', body) = apply_function_body (1+arity) in - let cache = Ident.create_local "cache" + let cache = V.create_local "cache" and obj = List.hd args - and tag = Ident.create_local "tag" in + and tag = V.create_local "tag" in let env = empty_env in let clos = let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in - let meths = Ident.create_local "meths" - and cached = Ident.create_local "cached" in - let real = Ident.create_local "real" in + let meths = V.create_local "meths" and cached = V.create_local "cached" in + let real = V.create_local "real" in let mask = get_field env (Cvar meths) 1 dbg in let cached_pos = Cvar cached in let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg); Cconst_int(3*size_addr-1)], dbg) in let tag' = Cop(Cload (Word_int, Mutable), [tag_pos], dbg) in Clet ( - meths, Cop(Cload (Word_val, Mutable), [obj], dbg), + VP.create meths, Cop(Cload (Word_val, Mutable), [obj], dbg), Clet ( - cached, + VP.create cached, Cop(Cand, [Cop(Cload (Word_int, Mutable), [cache], dbg); mask], dbg), Clet ( - real, + VP.create real, Cifthenelse(Cop(Ccmpa Cne, [tag'; tag], dbg), cache_public_method (Cvar meths) tag cache dbg, cached_pos), @@ -3237,7 +3239,7 @@ let send_function arity = Cconst_int(2*size_addr-1)], dbg)], dbg)))) in - let body = Clet(clos', clos, body) in + let body = Clet(VP.create clos', clos, body) in let cache = cache in let fun_args = [obj, typ_val; tag, typ_int; cache, typ_val] @@ -3245,7 +3247,7 @@ let send_function arity = let fun_name = "caml_send" ^ string_of_int arity in Cfunction {fun_name; - fun_args = fun_args; + fun_args = List.map (fun (arg, ty) -> VP.create arg, ty) fun_args; fun_body = body; fun_codegen_options = []; fun_dbg = Debuginfo.none } @@ -3256,7 +3258,7 @@ let apply_function arity = let fun_name = "caml_apply" ^ string_of_int arity in Cfunction {fun_name; - fun_args = List.map (fun id -> (id, typ_val)) all_args; + fun_args = List.map (fun arg -> (VP.create arg, typ_val)) all_args; fun_body = body; fun_codegen_options = []; fun_dbg = Debuginfo.none; @@ -3268,8 +3270,8 @@ let apply_function arity = let tuplify_function arity = let dbg = Debuginfo.none in - let arg = Ident.create_local "arg" in - let clos = Ident.create_local "clos" in + let arg = V.create_local "arg" in + let clos = V.create_local "clos" in let env = empty_env in let rec access_components i = if i >= arity @@ -3278,7 +3280,7 @@ let tuplify_function arity = let fun_name = "caml_tuplify" ^ string_of_int arity in Cfunction {fun_name; - fun_args = [arg, typ_val; clos, typ_val]; + fun_args = [VP.create arg, typ_val; VP.create clos, typ_val]; fun_body = Cop(Capply typ_val, get_field env (Cvar clos) 2 dbg :: access_components 0 @ [Cvar clos], @@ -3318,8 +3320,8 @@ let tuplify_function arity = let max_arity_optimized = 15 let final_curry_function arity = let dbg = Debuginfo.none in - let last_arg = Ident.create_local "arg" in - let last_clos = Ident.create_local "clos" in + let last_arg = V.create_local "arg" in + let last_clos = V.create_local "clos" in let env = empty_env in let rec curry_fun args clos n = if n = 0 then @@ -3330,14 +3332,14 @@ let final_curry_function arity = else if n = arity - 1 || arity > max_arity_optimized then begin - let newclos = Ident.create_local "clos" in - Clet(newclos, + let newclos = V.create_local "clos" in + Clet(VP.create newclos, get_field env (Cvar clos) 3 dbg, curry_fun (get_field env (Cvar clos) 2 dbg :: args) newclos (n-1)) end else begin - let newclos = Ident.create_local "clos" in - Clet(newclos, + let newclos = V.create_local "clos" in + Clet(VP.create newclos, get_field env (Cvar clos) 4 dbg, curry_fun (get_field env (Cvar clos) 3 dbg :: args) newclos (n-1)) @@ -3345,7 +3347,7 @@ let final_curry_function arity = Cfunction {fun_name = "caml_curry" ^ string_of_int arity ^ "_" ^ string_of_int (arity-1); - fun_args = [last_arg, typ_val; last_clos, typ_val]; + fun_args = [VP.create last_arg, typ_val; VP.create last_clos, typ_val]; fun_body = curry_fun [] last_clos (arity-1); fun_codegen_options = []; fun_dbg = Debuginfo.none } @@ -3358,10 +3360,10 @@ let rec intermediate_curry_functions arity num = else begin let name1 = "caml_curry" ^ string_of_int arity in let name2 = if num = 0 then name1 else name1 ^ "_" ^ string_of_int num in - let arg = Ident.create_local "arg" and clos = Ident.create_local "clos" in + let arg = V.create_local "arg" and clos = V.create_local "clos" in Cfunction {fun_name = name2; - fun_args = [arg, typ_val; clos, typ_val]; + fun_args = [VP.create arg, typ_val; VP.create clos, typ_val]; fun_body = if arity - num > 2 && arity <= max_arity_optimized then Cop(Calloc, @@ -3383,7 +3385,7 @@ let rec intermediate_curry_functions arity num = (if arity <= max_arity_optimized && arity - num > 2 then let rec iter i = if i <= arity then - let arg = Ident.create_local (Printf.sprintf "arg%d" i) in + let arg = V.create_local (Printf.sprintf "arg%d" i) in (arg, typ_val) :: iter (i+1) else [] in @@ -3394,15 +3396,19 @@ let rec intermediate_curry_functions arity num = (get_field env (Cvar clos) 2 dbg) :: args @ [Cvar clos], dbg) else - let newclos = Ident.create_local "clos" in - Clet(newclos, + let newclos = V.create_local "clos" in + Clet(VP.create newclos, get_field env (Cvar clos) 4 dbg, iter (i-1) (get_field env (Cvar clos) 3 dbg :: args) newclos) in + let fun_args = + List.map (fun (arg, ty) -> VP.create arg, ty) + (direct_args @ [clos, typ_val]) + in let cf = Cfunction {fun_name = name1 ^ "_" ^ string_of_int (num+1) ^ "_app"; - fun_args = direct_args @ [clos, typ_val]; + fun_args; fun_body = iter (num+1) (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; fun_codegen_options = []; diff --git a/asmcomp/debug/available_regs.ml b/asmcomp/debug/available_regs.ml index b95c6415d..9886f7729 100644 --- a/asmcomp/debug/available_regs.ml +++ b/asmcomp/debug/available_regs.ml @@ -18,6 +18,7 @@ module M = Mach module R = Reg module RAS = Reg_availability_set module RD = Reg_with_debug_info +module V = Backend_var (* This pass treats [avail_at_exit] like a "result" structure whereas the equivalent in [Liveness] is like an "environment". (Which means we need @@ -108,7 +109,8 @@ let rec available_regs (instr : M.instruction) match RD.debug_info reg with | None -> reg | Some debug_info -> - if Ident.same (RD.Debug_info.holds_value_of debug_info) ident + if V.same + (RD.Debug_info.holds_value_of debug_info) ident then RD.clear_debug_info reg else reg) avail_before diff --git a/asmcomp/debug/reg_availability_set.ml b/asmcomp/debug/reg_availability_set.ml index 832ff1413..fbff598d1 100644 --- a/asmcomp/debug/reg_availability_set.ml +++ b/asmcomp/debug/reg_availability_set.ml @@ -15,6 +15,7 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] module RD = Reg_with_debug_info +module V = Backend_var type t = | Ok of RD.Set.t @@ -69,15 +70,15 @@ let canonicalise availability = match availability with | Unreachable -> Unreachable | Ok availability -> - let regs_by_ident = Ident.Tbl.create 42 in + let regs_by_ident = V.Tbl.create 42 in RD.Set.iter (fun reg -> match RD.debug_info reg with | None -> () | Some debug_info -> let name = RD.Debug_info.holds_value_of debug_info in - if not (Ident.persistent name) then begin - match Ident.Tbl.find regs_by_ident name with - | exception Not_found -> Ident.Tbl.add regs_by_ident name reg + if not (V.persistent name) then begin + match V.Tbl.find regs_by_ident name with + | exception Not_found -> V.Tbl.add regs_by_ident name reg | (reg' : RD.t) -> (* We prefer registers that are assigned to the stack since they probably give longer available ranges (less likely to @@ -89,12 +90,12 @@ let canonicalise availability = | _, Unknown | Unknown, _ -> () | Stack _, Reg _ -> - Ident.Tbl.remove regs_by_ident name; - Ident.Tbl.add regs_by_ident name reg + V.Tbl.remove regs_by_ident name; + V.Tbl.add regs_by_ident name reg end) availability; let result = - Ident.Tbl.fold (fun _ident reg availability -> + V.Tbl.fold (fun _ident reg availability -> RD.Set.add reg availability) regs_by_ident RD.Set.empty diff --git a/asmcomp/debug/reg_with_debug_info.ml b/asmcomp/debug/reg_with_debug_info.ml index 24f7ac313..3dd0ce0c5 100644 --- a/asmcomp/debug/reg_with_debug_info.ml +++ b/asmcomp/debug/reg_with_debug_info.ml @@ -14,9 +14,11 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] +module V = Backend_var + module Debug_info = struct type t = { - holds_value_of : Ident.t; + holds_value_of : V.t; part_of_value : int; num_parts_of_value : int; which_parameter : int option; @@ -24,7 +26,7 @@ module Debug_info = struct } let compare t1 t2 = - let c = Ident.compare t1.holds_value_of t2.holds_value_of in + let c = V.compare t1.holds_value_of t2.holds_value_of in if c <> 0 then c else Stdlib.compare @@ -38,7 +40,7 @@ module Debug_info = struct let provenance t = t.provenance let print ppf t = - Format.fprintf ppf "%a" Ident.print t.holds_value_of; + Format.fprintf ppf "%a" V.print t.holds_value_of; if not (t.part_of_value = 0 && t.num_parts_of_value = 1) then begin Format.fprintf ppf "(%d/%d)" t.part_of_value t.num_parts_of_value end; @@ -140,7 +142,7 @@ module Order_distinguishing_names_and_locations = struct | None, Some _ -> -1 | Some _, None -> 1 | Some di1, Some di2 -> - let c = Ident.compare di1.holds_value_of di2.holds_value_of in + let c = V.compare di1.holds_value_of di2.holds_value_of in if c <> 0 then c else Stdlib.compare t1.reg.loc t2.reg.loc end diff --git a/asmcomp/debug/reg_with_debug_info.mli b/asmcomp/debug/reg_with_debug_info.mli index 2f0599d3f..b989bdeb8 100644 --- a/asmcomp/debug/reg_with_debug_info.mli +++ b/asmcomp/debug/reg_with_debug_info.mli @@ -20,7 +20,7 @@ module Debug_info : sig val compare : t -> t -> int - val holds_value_of : t -> Ident.t + val holds_value_of : t -> Backend_var.t (** The identifier that the register holds (part of) the value of. *) val part_of_value : t -> int @@ -39,7 +39,7 @@ type reg_with_debug_info = t val create : reg:Reg.t - -> holds_value_of:Ident.t + -> holds_value_of:Backend_var.t -> part_of_value:int -> num_parts_of_value:int -> which_parameter:int option diff --git a/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml index 88a4ca11a..9291d4256 100644 --- a/asmcomp/flambda_to_clambda.ml +++ b/asmcomp/flambda_to_clambda.ml @@ -16,6 +16,9 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] +module V = Backend_var +module VP = Backend_var.With_provenance + type 'a for_one_or_more_units = { fun_offset_table : int Closure_id.Map.t; fv_offset_table : int Var_within_closure.Map.t; @@ -109,11 +112,11 @@ module Env : sig val add_subst : t -> Variable.t -> Clambda.ulambda -> t val find_subst_exn : t -> Variable.t -> Clambda.ulambda - val add_fresh_ident : t -> Variable.t -> Ident.t * t - val ident_for_var_exn : t -> Variable.t -> Ident.t + val add_fresh_ident : t -> Variable.t -> V.t * t + val ident_for_var_exn : t -> Variable.t -> V.t - val add_fresh_mutable_ident : t -> Mutable_variable.t -> Ident.t * t - val ident_for_mutable_var_exn : t -> Mutable_variable.t -> Ident.t + val add_fresh_mutable_ident : t -> Mutable_variable.t -> V.t * t + val ident_for_mutable_var_exn : t -> Mutable_variable.t -> V.t val add_allocated_const : t -> Symbol.t -> Allocated_const.t -> t val allocated_const_for_symbol : t -> Symbol.t -> Allocated_const.t option @@ -122,8 +125,8 @@ module Env : sig end = struct type t = { subst : Clambda.ulambda Variable.Map.t; - var : Ident.t Variable.Map.t; - mutable_var : Ident.t Mutable_variable.Map.t; + var : V.t Variable.Map.t; + mutable_var : V.t Mutable_variable.Map.t; toplevel : bool; allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t; } @@ -144,14 +147,14 @@ end = struct let ident_for_var_exn t id = Variable.Map.find id t.var let add_fresh_ident t var = - let id = Ident.create_local (Variable.name var) in + let id = V.create_local (Variable.name var) in id, { t with var = Variable.Map.add var id t.var } let ident_for_mutable_var_exn t mut_var = Mutable_variable.Map.find mut_var t.mutable_var let add_fresh_mutable_ident t mut_var = - let id = Ident.create_local (Mutable_variable.name mut_var) in + let id = V.create_local (Mutable_variable.name mut_var) in let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in id, { t with mutable_var; } @@ -224,12 +227,13 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = | Let { var; defining_expr; body; _ } -> (* TODO: synthesize proper value_kind *) let id, env_body = Env.add_fresh_ident env var in - Ulet (Immutable, Pgenval, id, to_clambda_named t env var defining_expr, + Ulet (Immutable, Pgenval, VP.create id, + to_clambda_named t env var defining_expr, to_clambda t env_body body) | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> let id, env_body = Env.add_fresh_mutable_ident env mut_var in let def = subst_var env var in - Ulet (Mutable, contents_kind, id, def, to_clambda t env_body body) + Ulet (Mutable, contents_kind, VP.create id, def, to_clambda t env_body body) | Let_rec (defs, body) -> let env, defs = List.fold_right (fun (var, def) (env, defs) -> @@ -238,7 +242,9 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = defs (env, []) in let defs = - List.map (fun (id, var, def) -> id, to_clambda_named t env var def) defs + List.map (fun (id, var, def) -> + VP.create id, to_clambda_named t env var def) + defs in Uletrec (defs, to_clambda t env body) | Apply { func; args; kind = Direct direct_func; dbg = dbg } -> @@ -303,14 +309,15 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = let env_handler, ids = List.fold_right (fun var (env, ids) -> let id, env = Env.add_fresh_ident env var in - env, id :: ids) + env, VP.create id :: ids) vars (env, []) in Ucatch (Static_exception.to_int static_exn, ids, to_clambda t env body, to_clambda t env_handler handler) | Try_with (body, var, handler) -> let id, env_handler = Env.add_fresh_ident env var in - Utrywith (to_clambda t env body, id, to_clambda t env_handler handler) + Utrywith (to_clambda t env body, VP.create id, + to_clambda t env_handler handler) | If_then_else (arg, ifso, ifnot) -> Uifthenelse (subst_var env arg, to_clambda t env ifso, to_clambda t env ifnot) @@ -318,7 +325,7 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = Uwhile (to_clambda t env cond, to_clambda t env body) | For { bound_var; from_value; to_value; direction; body } -> let id, env_body = Env.add_fresh_ident env bound_var in - Ufor (id, subst_var env from_value, subst_var env to_value, + Ufor (VP.create id, subst_var env from_value, subst_var env to_value, direction, to_clambda t env_body body) | Assign { being_assigned; new_value } -> let id = @@ -466,7 +473,7 @@ and to_clambda_set_of_closures t env (({ function_decls; free_vars } : Flambda.set_of_closures) as set_of_closures) : Clambda.ulambda = let all_functions = Variable.Map.bindings function_decls.funs in - let env_var = Ident.create_local "env" in + let env_var = V.create_local "env" in let to_clambda_function (closure_id, (function_decl : Flambda.function_declaration)) : Clambda.ufunction = @@ -520,7 +527,7 @@ and to_clambda_set_of_closures t env in { label = Compilenv.function_label closure_id; arity = Flambda_utils.function_arity function_decl; - params = params @ [env_var]; + params = List.map (fun var -> VP.create var) (params @ [env_var]); body = to_clambda t env_body function_decl.body; dbg = function_decl.dbg; env = Some env_var; @@ -560,7 +567,7 @@ and to_clambda_closed_set_of_closures t env symbol in { label = Compilenv.function_label (Closure_id.wrap id); arity = Flambda_utils.function_arity function_decl; - params; + params = List.map (fun var -> VP.create var) params; body = to_clambda t env_body function_decl.body; dbg = function_decl.dbg; env = None; diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 756ec61a0..a03481fcd 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -61,7 +61,7 @@ type operation = | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat | Ispecific of Arch.specific_operation - | Iname_for_debugger of { ident : Ident.t; which_parameter : int option; + | Iname_for_debugger of { ident : Backend_var.t; which_parameter : int option; provenance : unit option; is_assignment : bool; } type instruction = diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index be17ba2bb..8ec960a91 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -71,7 +71,7 @@ type operation = | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat | Ispecific of Arch.specific_operation - | Iname_for_debugger of { ident : Ident.t; which_parameter : int option; + | Iname_for_debugger of { ident : Backend_var.t; which_parameter : int option; provenance : unit option; is_assignment : bool; } (** [Iname_for_debugger] has the following semantics: (a) The argument register(s) is/are deemed to contain the value of the diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml index c353b3df8..43cd8ec3c 100644 --- a/asmcomp/printclambda.ml +++ b/asmcomp/printclambda.ml @@ -18,6 +18,9 @@ open Format open Asttypes open Clambda +module V = Backend_var +module VP = Backend_var.With_provenance + let mutable_flag = function | Mutable-> "[mut]" | Immutable -> "" @@ -50,7 +53,7 @@ let rec structured_constant ppf = function | Uconst_string s -> fprintf ppf "%S" s | Uconst_closure(clos, sym, fv) -> let idents ppf = - List.iter (fprintf ppf "@ %a" Ident.print)in + List.iter (fprintf ppf "@ %a" VP.print) in let one_fun ppf f = fprintf ppf "(fun@ %s@ %d@ @[<2>%a@]@ @[<2>%a@])" f.label f.arity idents f.params lam f.body in @@ -70,7 +73,7 @@ and uconstant ppf = function and lam ppf = function | Uvar id -> - Ident.print ppf id + V.print ppf id | Uconst c -> uconstant ppf c | Udirect_apply(f, largs, _) -> let lams ppf largs = @@ -82,7 +85,7 @@ and lam ppf = function fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs | Uclosure(clos, fv) -> let idents ppf = - List.iter (fprintf ppf "@ %a" Ident.print)in + List.iter (fprintf ppf "@ %a" VP.print) in let one_fun ppf f = fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])" f.label f.arity idents f.params lam f.body in @@ -96,11 +99,13 @@ and lam ppf = function let rec letbody ul = match ul with | Ulet(mut, kind, id, arg, body) -> fprintf ppf "@ @[<2>%a%s%s@ %a@]" - Ident.print id (mutable_flag mut) (value_kind kind) lam arg; + VP.print id + (mutable_flag mut) (value_kind kind) lam arg; letbody body | _ -> ul in fprintf ppf "@[<2>(let@ @[(@[<2>%a%s%s@ %a@]" - Ident.print id (mutable_flag mut) (value_kind kind) lam arg; + VP.print id (mutable_flag mut) + (value_kind kind) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Uletrec(id_arg_list, body) -> @@ -109,7 +114,9 @@ and lam ppf = function List.iter (fun (id, l) -> if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) + fprintf ppf "@[<2>%a@ %a@]" + VP.print id + lam l) id_arg_list in fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body @@ -161,13 +168,13 @@ and lam ppf = function | [] -> () | _ -> List.iter - (fun x -> fprintf ppf " %a" Ident.print x) + (fun x -> fprintf ppf " %a" VP.print x) vars) vars lam lhandler | Utrywith(lbody, param, lhandler) -> fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody Ident.print param lam lhandler + lam lbody VP.print param lam lhandler | Uifthenelse(lcond, lif, lelse) -> fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse | Usequence(l1, l2) -> @@ -176,11 +183,11 @@ and lam ppf = function fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody | Ufor(param, lo, hi, dir, body) -> fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - Ident.print param lam lo + VP.print param lam lo (match dir with Upto -> "to" | Downto -> "downto") lam hi lam body | Uassign(id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr + fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr | Usend (k, met, obj, largs, _) -> let args ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index bcb97f2fc..d19233d0d 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -18,6 +18,9 @@ open Format open Cmm +module V = Backend_var +module VP = Backend_var.With_provenance + let rec_flag ppf = function | Nonrecursive -> () | Recursive -> fprintf ppf " rec" @@ -127,10 +130,11 @@ let rec expr ppf = function | Cconst_symbol s -> fprintf ppf "\"%s\"" s | Cconst_pointer n -> fprintf ppf "%ia" n | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) - | Cvar id -> Ident.print ppf id + | Cvar id -> V.print ppf id | Clet(id, def, (Clet(_, _, _) as body)) -> let print_binding id ppf def = - fprintf ppf "@[<2>%a@ %a@]" Ident.print id expr def in + fprintf ppf "@[<2>%a@ %a@]" + VP.print id expr def in let rec in_part ppf = function | Clet(id, def, body) -> fprintf ppf "@ %a" (print_binding id) def; @@ -142,9 +146,9 @@ let rec expr ppf = function | Clet(id, def, body) -> fprintf ppf "@[<2>(let@ @[<2>%a@ %a@]@ %a)@]" - Ident.print id expr def sequence body + VP.print id expr def sequence body | Cassign(id, exp) -> - fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp + fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" V.print id expr exp | Ctuple el -> let tuple ppf el = let first = ref true in @@ -186,7 +190,8 @@ let rec expr ppf = function (fun ppf ids -> List.iter (fun (id, ty) -> - fprintf ppf "@ %a: %a" Ident.print id machtype ty) + fprintf ppf "@ %a: %a" + VP.print id machtype ty) ids) ids sequence e2 in @@ -204,7 +209,7 @@ let rec expr ppf = function fprintf ppf ")@]" | Ctrywith(e1, id, e2) -> fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]" - sequence e1 Ident.print id sequence e2 + sequence e1 VP.print id sequence e2 and sequence ppf = function | Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2 @@ -218,7 +223,7 @@ let fundecl ppf f = List.iter (fun (id, ty) -> if !first then first := false else fprintf ppf "@ "; - fprintf ppf "%a: %a" Ident.print id machtype ty) + fprintf ppf "%a: %a" VP.print id machtype ty) cases in fprintf ppf "@[<1>(function%s %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." (Debuginfo.to_string f.fun_dbg) f.fun_name diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 57b111ce4..f5be11c64 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -21,6 +21,8 @@ open Reg open Mach open Interval +module V = Backend_var + let reg ppf r = if not (Reg.anonymous r) then fprintf ppf "%s" (Reg.name r) @@ -158,7 +160,7 @@ let operation op arg ppf res = | Iintoffloat -> fprintf ppf "intoffloat %a" reg arg.(0) | Iname_for_debugger { ident; which_parameter; } -> fprintf ppf "name_for_debugger %a%s=%a" - Ident.print ident + V.print ident (match which_parameter with | None -> "" | Some index -> sprintf "[P%d]" index) diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index 441a6d38a..ee3173d58 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -15,20 +15,22 @@ open Cmm +module V = Backend_var + module Raw_name = struct type t = | Anon | R - | Ident of Ident.t + | Var of V.t - let create_from_ident ident = Ident ident + let create_from_var var = Var var let to_string t = match t with | Anon -> None | R -> Some "R" - | Ident ident -> - let name = Ident.name ident in + | Var var -> + let name = V.name var in if String.length name <= 0 then None else Some name end diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli index d918f07ef..cd376394e 100644 --- a/asmcomp/reg.mli +++ b/asmcomp/reg.mli @@ -17,7 +17,7 @@ module Raw_name : sig type t - val create_from_ident : Ident.t -> t + val create_from_var : Backend_var.t -> t end type t = diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 413dc34a7..586a5b869 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -22,28 +22,33 @@ open Reg open Mach module Int = Numbers.Int +module V = Backend_var +module VP = Backend_var.With_provenance type environment = - { vars : Reg.t array Ident.Map.t; + { vars : (Reg.t array * Backend_var.Provenance.t option) V.Map.t; static_exceptions : Reg.t array list Int.Map.t; (** Which registers must be populated when jumping to the given handler. *) } -let env_add id v env = - { env with vars = Ident.Map.add id v env.vars } +let env_add var regs env = + let provenance = VP.provenance var in + let var = VP.var var in + { env with vars = V.Map.add var (regs, provenance) env.vars } let env_add_static_exception id v env = { env with static_exceptions = Int.Map.add id v env.static_exceptions } let env_find id env = - Ident.Map.find id env.vars + let regs, _provenance = V.Map.find id env.vars in + regs let env_find_static_exception id env = Int.Map.find id env.static_exceptions let env_empty = { - vars = Ident.Map.empty; + vars = V.Map.empty; static_exceptions = Int.Map.empty; } @@ -83,26 +88,26 @@ let size_expr (env:environment) exp = | Cblockheader _ -> Arch.size_int | Cvar id -> begin try - Ident.Map.find id localenv + V.Map.find id localenv with Not_found -> try let regs = env_find id env in size_machtype (Array.map (fun r -> r.typ) regs) with Not_found -> fatal_error("Selection.size_expr: unbound var " ^ - Ident.unique_name id) + V.unique_name id) end | Ctuple el -> List.fold_right (fun e sz -> size localenv e + sz) el 0 | Cop(op, _, _) -> size_machtype(oper_result_type op) | Clet(id, arg, body) -> - size (Ident.Map.add id (size localenv arg) localenv) body + size (V.Map.add (VP.var id) (size localenv arg) localenv) body | Csequence(_e1, e2) -> size localenv e2 | _ -> fatal_error "Selection.size_expr" - in size Ident.Map.empty exp + in size V.Map.empty exp (* Swap the two arguments of an integer comparison *) @@ -122,11 +127,12 @@ let all_regs_anonymous rv = false let name_regs id rv = + let id = VP.var id in if Array.length rv = 1 then - rv.(0).raw_name <- Raw_name.create_from_ident id + rv.(0).raw_name <- Raw_name.create_from_var id else for i = 0 to Array.length rv - 1 do - rv.(i).raw_name <- Raw_name.create_from_ident id; + rv.(i).raw_name <- Raw_name.create_from_var id; rv.(i).part <- Some i done @@ -657,7 +663,7 @@ method emit_expr (env:environment) exp = begin try Some(env_find v env) with Not_found -> - fatal_error("Selection.emit_expr: unbound var " ^ Ident.unique_name v) + fatal_error("Selection.emit_expr: unbound var " ^ V.unique_name v) end | Clet(v, e1, e2) -> begin match self#emit_expr env e1 with @@ -669,7 +675,7 @@ method emit_expr (env:environment) exp = try env_find v env with Not_found -> - fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in + fatal_error ("Selection.emit_expr: unbound var " ^ V.name v) in begin match self#emit_expr env e1 with None -> None | Some r1 -> self#adjust_types r1 rv; self#insert_moves r1 rv; Some [||] @@ -928,15 +934,15 @@ method private emit_parts (env:environment) ~effects_after exp = Some (Ctuple [], env) else begin (* The normal case *) - let id = Ident.create_local "bind" in + let id = V.create_local "bind" in if all_regs_anonymous r then (* r is an anonymous, unshared register; use it directly *) - Some (Cvar id, env_add id r env) + Some (Cvar id, env_add (VP.create id) r env) else begin (* Introduce a fresh temp to hold the result *) let tmp = Reg.createv_like r in self#insert_moves r tmp; - Some (Cvar id, env_add id tmp env) + Some (Cvar id, env_add (VP.create id) tmp env) end end end @@ -1201,8 +1207,8 @@ method emit_fundecl f = if not Config.spacetime then None, env else begin let reg = self#regs_for typ_int in - let node_hole = Ident.create_local "spacetime_node_hole" in - Some (node_hole, reg), env_add node_hole reg env + let node_hole = V.create_local "spacetime_node_hole" in + Some (node_hole, reg), env_add (VP.create node_hole) reg env end in self#emit_tail env f.Cmm.fun_body; diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 3cd24787e..003d70673 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -18,9 +18,13 @@ type environment -val env_add : Ident.t -> Reg.t array -> environment -> environment +val env_add + : Backend_var.With_provenance.t + -> Reg.t array + -> environment + -> environment -val env_find : Ident.t -> environment -> Reg.t array +val env_find : Backend_var.t -> environment -> Reg.t array val size_expr : environment -> Cmm.expression -> int @@ -165,7 +169,7 @@ class virtual selector_generic : object : Cmm.fundecl -> loc_arg:Reg.t array -> rarg:Reg.t array - -> spacetime_node_hole:(Ident.t * Reg.t array) option + -> spacetime_node_hole:(Backend_var.t * Reg.t array) option -> env:environment -> Mach.spacetime_shape option diff --git a/asmcomp/spacetime_profiling.ml b/asmcomp/spacetime_profiling.ml index c739e43bc..51d418a5c 100644 --- a/asmcomp/spacetime_profiling.ml +++ b/asmcomp/spacetime_profiling.ml @@ -12,14 +12,17 @@ (* *) (**************************************************************************) +module V = Backend_var +module VP = Backend_var.With_provenance + let node_num_header_words = 2 (* [Node_num_header_words] in the runtime. *) let index_within_node = ref node_num_header_words -(* The [lazy]s are to ensure that we don't create [Ident.t]s at toplevel +(* The [lazy]s are to ensure that we don't create [V.t]s at toplevel when not using Spacetime profiling. (This could cause stamps to differ between bytecode and native .cmis when no .mli is present, e.g. arch.ml.) *) -let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create_local "dummy"))) -let spacetime_node_ident = ref (lazy (Ident.create_local "dummy")) +let spacetime_node = ref (lazy (Cmm.Cvar (V.create_local "dummy"))) +let spacetime_node_ident = ref (lazy (V.create_local "dummy")) let current_function_label = ref "" let direct_tail_call_point_indexes = ref [] @@ -55,15 +58,15 @@ let reset ~spacetime_node_ident:ident ~function_label = reverse_shape := [] let code_for_function_prologue ~function_name ~node_hole = - let node = Ident.create_local "node" in - let new_node = Ident.create_local "new_node" in - let must_allocate_node = Ident.create_local "must_allocate_node" in - let is_new_node = Ident.create_local "is_new_node" in + let node = V.create_local "node" in + let new_node = V.create_local "new_node" in + let must_allocate_node = V.create_local "must_allocate_node" in + let is_new_node = V.create_local "is_new_node" in let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in let dbg = Debuginfo.none in let open Cmm in let initialize_direct_tail_call_points_and_return_node = - let new_node_encoded = Ident.create_local "new_node_encoded" in + let new_node_encoded = V.create_local "new_node_encoded" in (* The callee node pointers within direct tail call points must initially point back at the start of the current node and be marked as per [Encode_tail_caller_node] in the runtime. *) @@ -83,42 +86,43 @@ let code_for_function_prologue ~function_name ~node_hole = match indexes with | [] -> body | _ -> - Clet (new_node_encoded, + Clet (VP.create new_node_encoded, (* Cf. [Encode_tail_caller_node] in the runtime. *) Cop (Cor, [Cvar new_node; Cconst_int 1], dbg), body) in - let pc = Ident.create_local "pc" in - Clet (node, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg), - Clet (must_allocate_node, - Cop (Cand, [Cvar node; Cconst_int 1], dbg), - Cifthenelse ( - Cop (Ccmpi Cne, [Cvar must_allocate_node; Cconst_int 1], dbg), - Cvar node, - Clet (is_new_node, - Clet (pc, Cconst_symbol function_name, - Cop (Cextcall ("caml_spacetime_allocate_node", - [| Int |], false, None), - [Cconst_int (1 (* header *) + !index_within_node); - Cvar pc; - Cvar node_hole; - ], - dbg)), - Clet (new_node, - Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg), - if no_tail_calls then Cvar new_node - else - Cifthenelse ( - Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0], dbg), - Cvar new_node, - initialize_direct_tail_call_points_and_return_node)))))) + let pc = V.create_local "pc" in + Clet (VP.create node, + Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg), + Clet (VP.create must_allocate_node, + Cop (Cand, [Cvar node; Cconst_int 1], dbg), + Cifthenelse ( + Cop (Ccmpi Cne, [Cvar must_allocate_node; Cconst_int 1], dbg), + Cvar node, + Clet (VP.create is_new_node, + Clet (VP.create pc, Cconst_symbol function_name, + Cop (Cextcall ("caml_spacetime_allocate_node", + [| Int |], false, None), + [Cconst_int (1 (* header *) + !index_within_node); + Cvar pc; + Cvar node_hole; + ], + dbg)), + Clet (VP.create new_node, + Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg), + if no_tail_calls then Cvar new_node + else + Cifthenelse ( + Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0], dbg), + Cvar new_node, + initialize_direct_tail_call_points_and_return_node)))))) let code_for_blockheader ~value's_header ~node ~dbg = let num_words = Nativeint.shift_right_logical value's_header 10 in - let existing_profinfo = Ident.create_local "existing_profinfo" in - let existing_count = Ident.create_local "existing_count" in - let profinfo = Ident.create_local "profinfo" in - let address_of_profinfo = Ident.create_local "address_of_profinfo" in + let existing_profinfo = V.create_local "existing_profinfo" in + let existing_count = V.create_local "existing_count" in + let profinfo = V.create_local "profinfo" in + let address_of_profinfo = V.create_local "address_of_profinfo" in let label = Cmm.new_label () in let index_within_node = next_index_within_node ~part_of_shape:Mach.Allocation_point ~label @@ -143,20 +147,20 @@ let code_for_blockheader ~value's_header ~node ~dbg = (* Check if we have already allocated a profinfo value for this allocation point with the current backtrace. If so, use that value; if not, allocate a new one. *) - Clet (address_of_profinfo, + Clet (VP.create address_of_profinfo, Cop (Caddi, [ Cvar node; Cconst_int offset_into_node; ], dbg), - Clet (existing_profinfo, + Clet (VP.create existing_profinfo, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar address_of_profinfo], dbg), - Clet (profinfo, + Clet (VP.create profinfo, Cifthenelse ( Cop (Ccmpi Cne, [Cvar existing_profinfo; Cconst_int 1 (* () *)], dbg), Cvar existing_profinfo, generate_new_profinfo), - Clet (existing_count, + Clet (VP.create existing_count, Cop (Cload (Word_int, Asttypes.Mutable), [ Cop (Caddi, [Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg) @@ -216,10 +220,10 @@ let code_for_call ~node ~callee ~is_tail ~label = index_within_node::!direct_tail_call_point_indexes | Direct _ | Indirect _ -> () end; - let place_within_node = Ident.create_local "place_within_node" in + let place_within_node = V.create_local "place_within_node" in let dbg = Debuginfo.none in let open Cmm in - Clet (place_within_node, + Clet (VP.create place_within_node, Cop (Caddi, [node; Cconst_int (index_within_node * Arch.size_addr)], dbg), (* The following code returns the address that is to be moved into the (hard) node hole pointer register immediately before the call. @@ -227,11 +231,11 @@ let code_for_call ~node ~callee ~is_tail ~label = match callee with | Direct _callee -> if Config.enable_call_counts then begin - let count_addr = Ident.create_local "call_count_addr" in - let count = Ident.create_local "call_count" in - Clet (count_addr, + let count_addr = V.create_local "call_count_addr" in + let count = V.create_local "call_count" in + Clet (VP.create count_addr, Cop (Caddi, [Cvar place_within_node; Cconst_int Arch.size_addr], dbg), - Clet (count, + Clet (VP.create count, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar count_addr], dbg), Csequence ( Cop (Cstore (Word_int, Lambda.Assignment), @@ -276,8 +280,8 @@ class virtual instruction_selection = object (self) ~label_after = (* [callee] is a pseudoregister, so we have to bind it in the environment and reference the variable to which it is bound. *) - let callee_ident = Ident.create_local "callee" in - let env = Selectgen.env_add callee_ident [| callee |] env in + let callee_ident = V.create_local "callee" in + let env = Selectgen.env_add (VP.create callee_ident) [| callee |] env in let instrumentation = code_for_call ~node:(Lazy.force !spacetime_node) @@ -416,7 +420,7 @@ class virtual instruction_selection = object (self) method! initial_env () = let env = super#initial_env () in if Config.spacetime then - Selectgen.env_add (Lazy.force !spacetime_node_ident) + Selectgen.env_add (VP.create (Lazy.force !spacetime_node_ident)) (self#regs_for Cmm.typ_int) env else env @@ -424,7 +428,7 @@ class virtual instruction_selection = object (self) method! emit_fundecl f = if Config.spacetime then begin disable_instrumentation <- false; - let node = Ident.create_local "spacetime_node" in + let node = V.create_local "spacetime_node" in reset ~spacetime_node_ident:node ~function_label:f.Cmm.fun_name end; super#emit_fundecl f diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml index 49abe3786..f4f9240bd 100644 --- a/asmcomp/strmatch.ml +++ b/asmcomp/strmatch.ml @@ -18,6 +18,9 @@ open Lambda open Cmm +module V = Backend_var +module VP = Backend_var.With_provenance + module type I = sig val string_block_length : Cmm.expression -> Cmm.expression val transl_switch : @@ -67,8 +70,8 @@ module Make(I:I) = struct (* Utilities *) - let gen_cell_id () = Ident.create_local "cell" - let gen_size_id () = Ident.create_local "size" + let gen_cell_id () = V.create_local "cell" + let gen_size_id () = V.create_local "size" let mk_let_cell id str ind body = let dbg = Debuginfo.none in @@ -293,7 +296,7 @@ module Make(I:I) = struct else let lt,midkey,ge = split_env len env in mk_lt id midkey (comp_rec lt) (comp_rec ge) in - mk_let_cell id str idx (comp_rec env) + mk_let_cell (VP.create id) str idx (comp_rec env) (* Recursive 'list of cells' compile function: @@ -352,7 +355,7 @@ module Make(I:I) = struct let id = gen_size_id () in let loc = Debuginfo.to_location dbg in let switch = I.transl_switch loc (Cvar id) 1 max_int size_cases default in - mk_let_size id str switch + mk_let_size (VP.create id) str switch (* Compilation entry point: we choose to switch diff --git a/asmcomp/un_anf.ml b/asmcomp/un_anf.ml index 2094a0ccf..51fbf8425 100644 --- a/asmcomp/un_anf.ml +++ b/asmcomp/un_anf.ml @@ -16,16 +16,19 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] -(* We say that an [Ident.t] is "linear" iff: +module V = Backend_var +module VP = Backend_var.With_provenance + +(* We say that an [V.t] is "linear" iff: (a) it is used exactly once; (b) it is never assigned to (using [Uassign]). *) -type ident_info = - { used : Ident.Set.t; - linear : Ident.Set.t; - assigned : Ident.Set.t; - closure_environment : Ident.Set.t; - let_bound_vars_that_can_be_moved : Ident.Set.t; +type var_info = + { used : V.Set.t; + linear : V.Set.t; + assigned : V.Set.t; + closure_environment : V.Set.t; + let_bound_vars_that_can_be_moved : V.Set.t; } let ignore_uconstant (_ : Clambda.uconstant) = () @@ -34,12 +37,13 @@ let ignore_ulambda_list (_ : Clambda.ulambda list) = () let ignore_function_label (_ : Clambda.function_label) = () let ignore_debuginfo (_ : Debuginfo.t) = () let ignore_int (_ : int) = () -let ignore_ident (_ : Ident.t) = () -let ignore_ident_option (_ : Ident.t option) = () +let ignore_var (_ : V.t) = () +let ignore_var_option (_ : V.t option) = () let ignore_primitive (_ : Lambda.primitive) = () let ignore_string (_ : string) = () let ignore_int_array (_ : int array) = () -let ignore_ident_list (_ : Ident.t list) = () +let ignore_var_with_provenance (_ : VP.t) = () +let ignore_var_with_provenance_list (_ : VP.t list) = () let ignore_direction_flag (_ : Asttypes.direction_flag) = () let ignore_meth_kind (_ : Lambda.meth_kind) = () @@ -47,27 +51,27 @@ let ignore_meth_kind (_ : Lambda.meth_kind) = () once (need to analyse exactly what the calls are from Cmmgen into this module). *) -let closure_environment_ident (ufunction:Clambda.ufunction) = +let closure_environment_var (ufunction:Clambda.ufunction) = (* The argument after the arity is the environment *) if List.length ufunction.params = ufunction.arity + 1 then let env_var = List.nth ufunction.params ufunction.arity in - assert(Ident.name env_var = "env"); + assert (VP.name env_var = "env"); Some env_var else (* closed function, no environment *) None -let make_ident_info (clam : Clambda.ulambda) : ident_info = - let t : int Ident.Tbl.t = Ident.Tbl.create 42 in - let assigned_idents = ref Ident.Set.empty in - let environment_idents = ref Ident.Set.empty in +let make_var_info (clam : Clambda.ulambda) : var_info = + let t : int V.Tbl.t = V.Tbl.create 42 in + let assigned_vars = ref V.Set.empty in + let environment_vars = ref V.Set.empty in let rec loop : Clambda.ulambda -> unit = function (* No underscores in the pattern match, to reduce the chance of failing to traverse some subexpression. *) - | Uvar id -> - begin match Ident.Tbl.find t id with - | n -> Ident.Tbl.replace t id (n + 1) - | exception Not_found -> Ident.Tbl.add t id 1 + | Uvar var -> + begin match V.Tbl.find t var with + | n -> V.Tbl.replace t var (n + 1) + | exception Not_found -> V.Tbl.add t var 1 end | Uconst const -> (* The only variables that might occur in [const] are those in constant @@ -89,27 +93,27 @@ let make_ident_info (clam : Clambda.ulambda) : ident_info = List.iter loop captured_variables; List.iter (fun ( { Clambda. label; arity; params; body; dbg; env; } as clos) -> - (match closure_environment_ident clos with + (match closure_environment_var clos with | None -> () | Some env_var -> - environment_idents := - Ident.Set.add env_var !environment_idents); + environment_vars := + V.Set.add (VP.var env_var) !environment_vars); ignore_function_label label; ignore_int arity; - ignore_ident_list params; + ignore_var_with_provenance_list params; loop body; ignore_debuginfo dbg; - ignore_ident_option env) + ignore_var_option env) functions | Uoffset (expr, offset) -> loop expr; ignore_int offset - | Ulet (_let_kind, _value_kind, _ident, def, body) -> + | Ulet (_let_kind, _value_kind, _var, def, body) -> loop def; loop body | Uletrec (defs, body) -> - List.iter (fun (ident, def) -> - ignore_ident ident; + List.iter (fun (var, def) -> + ignore_var_with_provenance var; loop def) defs; loop body @@ -135,14 +139,14 @@ let make_ident_info (clam : Clambda.ulambda) : ident_info = | Ustaticfail (static_exn, args) -> ignore_int static_exn; List.iter loop args - | Ucatch (static_exn, idents, body, handler) -> + | Ucatch (static_exn, vars, body, handler) -> ignore_int static_exn; - ignore_ident_list idents; + ignore_var_with_provenance_list vars; loop body; loop handler - | Utrywith (body, ident, handler) -> + | Utrywith (body, var, handler) -> loop body; - ignore_ident ident; + ignore_var_with_provenance var; loop handler | Uifthenelse (cond, ifso, ifnot) -> loop cond; @@ -154,14 +158,14 @@ let make_ident_info (clam : Clambda.ulambda) : ident_info = | Uwhile (cond, body) -> loop cond; loop body - | Ufor (ident, low, high, direction_flag, body) -> - ignore_ident ident; + | Ufor (var, low, high, direction_flag, body) -> + ignore_var_with_provenance var; loop low; loop high; ignore_direction_flag direction_flag; loop body - | Uassign (ident, expr) -> - assigned_idents := Ident.Set.add ident !assigned_idents; + | Uassign (var, expr) -> + assigned_vars := V.Set.add var !assigned_vars; loop expr | Usend (meth_kind, e1, e2, args, dbg) -> ignore_meth_kind meth_kind; @@ -174,24 +178,24 @@ let make_ident_info (clam : Clambda.ulambda) : ident_info = in loop clam; let linear = - Ident.Tbl.fold (fun id n acc -> + V.Tbl.fold (fun var n acc -> assert (n >= 1); - if n = 1 && not (Ident.Set.mem id !assigned_idents) - then Ident.Set.add id acc + if n = 1 && not (V.Set.mem var !assigned_vars) + then V.Set.add var acc else acc) - t Ident.Set.empty + t V.Set.empty in - let assigned = !assigned_idents in + let assigned = !assigned_vars in let used = (* This doesn't work transitively and thus is somewhat restricted. In particular, it does not allow us to get rid of useless chains of [let]s. However it should be sufficient to remove the majority of unnecessary [let] bindings that might hinder [Cmmgen]. *) - Ident.Tbl.fold (fun id _n acc -> Ident.Set.add id acc) + V.Tbl.fold (fun var _n acc -> V.Set.add var acc) t assigned in - { used; linear; assigned; closure_environment = !environment_idents; - let_bound_vars_that_can_be_moved = Ident.Set.empty; + { used; linear; assigned; closure_environment = !environment_vars; + let_bound_vars_that_can_be_moved = V.Set.empty; } (* When sequences of [let]-bindings match the evaluation order in a subsequent @@ -200,9 +204,9 @@ let make_ident_info (clam : Clambda.ulambda) : ident_info = variables that are known to be constant), and it is known that there were no intervening side-effects during the evaluation of the [let]-bindings, permit substitution of the variables for their defining expressions. *) -let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = - let obviously_constant = ref Ident.Set.empty in - let can_move = ref Ident.Set.empty in +let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = + let obviously_constant = ref V.Set.empty in + let can_move = ref V.Set.empty in let let_stack = ref [] in let examine_argument_list args = let rec loop let_bound_vars (args : Clambda.ulambda list) = @@ -217,14 +221,14 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = is left empty. *) [] | let_bound_vars, (Uvar arg)::args - when Ident.Set.mem arg !obviously_constant -> + when V.Set.mem arg !obviously_constant -> loop let_bound_vars args | let_bound_var::let_bound_vars, (Uvar arg)::args - when Ident.same let_bound_var arg - && not (Ident.Set.mem arg ident_info.assigned) -> - assert (Ident.Set.mem arg ident_info.used); - assert (Ident.Set.mem arg ident_info.linear); - can_move := Ident.Set.add arg !can_move; + when V.same let_bound_var arg + && not (V.Set.mem arg var_info.assigned) -> + assert (V.Set.mem arg var_info.used); + assert (V.Set.mem arg var_info.linear); + can_move := V.Set.add arg !can_move; loop let_bound_vars args | _::_, _::_ -> (* The [let] sequence has ceased to match the evaluation order @@ -238,8 +242,8 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = let_stack := loop !let_stack args in let rec loop : Clambda.ulambda -> unit = function - | Uvar ident -> - if Ident.Set.mem ident ident_info.assigned then begin + | Uvar var -> + if V.Set.mem var var_info.assigned then begin let_stack := [] end | Uconst const -> @@ -260,29 +264,30 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = List.iter (fun { Clambda. label; arity; params; body; dbg; env; } -> ignore_function_label label; ignore_int arity; - ignore_ident_list params; + ignore_var_with_provenance_list params; let_stack := []; loop body; let_stack := []; ignore_debuginfo dbg; - ignore_ident_option env) + ignore_var_option env) functions | Uoffset (expr, offset) -> (* [expr] should usually be a variable. *) examine_argument_list [expr]; ignore_int offset - | Ulet (_let_kind, _value_kind, ident, def, body) -> + | Ulet (_let_kind, _value_kind, var, def, body) -> + let var = VP.var var in begin match def with | Uconst _ -> (* The defining expression is obviously constant, so we don't have to put this [let] on the stack, and we don't have to traverse the defining expression either. *) - obviously_constant := Ident.Set.add ident !obviously_constant; + obviously_constant := V.Set.add var !obviously_constant; loop body | _ -> loop def; - if Ident.Set.mem ident ident_info.linear then begin - let_stack := ident::!let_stack + if V.Set.mem var var_info.linear then begin + let_stack := var::!let_stack end else begin (* If we encounter a non-linear [let]-binding then we must clear the let stack, since we cannot now move any previous binding @@ -295,8 +300,8 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = (* Evaluation order for [defs] is not defined, and this case probably isn't important for [Cmmgen] anyway. *) let_stack := []; - List.iter (fun (ident, def) -> - ignore_ident ident; + List.iter (fun (var, def) -> + ignore_var_with_provenance var; loop def; let_stack := []) defs; @@ -333,19 +338,19 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = | Ustaticfail (static_exn, args) -> ignore_int static_exn; examine_argument_list args - | Ucatch (static_exn, idents, body, handler) -> + | Ucatch (static_exn, vars, body, handler) -> ignore_int static_exn; - ignore_ident_list idents; + ignore_var_with_provenance_list vars; let_stack := []; loop body; let_stack := []; loop handler; let_stack := [] - | Utrywith (body, ident, handler) -> + | Utrywith (body, var, handler) -> let_stack := []; loop body; let_stack := []; - ignore_ident ident; + ignore_var_with_provenance var; loop handler; let_stack := [] | Uifthenelse (cond, ifso, ifnot) -> @@ -366,8 +371,8 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = let_stack := []; loop body; let_stack := [] - | Ufor (ident, low, high, direction_flag, body) -> - ignore_ident ident; + | Ufor (var, low, high, direction_flag, body) -> + ignore_var_with_provenance var; (* Cmmgen generates code that evaluates low before high, but we don't do anything here at the moment anyway. *) ignore_ulambda low; @@ -376,8 +381,8 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = let_stack := []; loop body; let_stack := [] - | Uassign (ident, expr) -> - ignore_ident ident; + | Uassign (var, expr) -> + ignore_var var; ignore_ulambda expr; let_stack := [] | Usend (meth_kind, e1, e2, args, dbg) -> @@ -399,15 +404,15 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) : Clambda.ulambda = match clam with - | Uvar id -> - if not (Ident.Set.mem id is_let_moveable) then + | Uvar var -> + if not (V.Set.mem var is_let_moveable) then clam else - begin match Ident.Map.find id env with + begin match V.Map.find var env with | clam -> clam | exception Not_found -> - Misc.fatal_errorf "substitute_let_moveable: Unbound identifier %a" - Ident.print id + Misc.fatal_errorf "substitute_let_moveable: Unbound variable %a" + V.print var end | Uconst _ -> clam | Udirect_apply (label, args, dbg) -> @@ -433,18 +438,18 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) | Uoffset (clam, n) -> let clam = substitute_let_moveable is_let_moveable env clam in Uoffset (clam, n) - | Ulet (let_kind, value_kind, id, def, body) -> + | Ulet (let_kind, value_kind, var, def, body) -> let def = substitute_let_moveable is_let_moveable env def in - if Ident.Set.mem id is_let_moveable then - let env = Ident.Map.add id def env in + if V.Set.mem (VP.var var) is_let_moveable then + let env = V.Map.add (VP.var var) def env in substitute_let_moveable is_let_moveable env body else Ulet (let_kind, value_kind, - id, def, substitute_let_moveable is_let_moveable env body) + var, def, substitute_let_moveable is_let_moveable env body) | Uletrec (defs, body) -> let defs = - List.map (fun (id, def) -> - id, substitute_let_moveable is_let_moveable env def) + List.map (fun (var, def) -> + var, substitute_let_moveable is_let_moveable env def) defs in let body = substitute_let_moveable is_let_moveable env body in @@ -479,14 +484,14 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) | Ustaticfail (n, args) -> let args = substitute_let_moveable_list is_let_moveable env args in Ustaticfail (n, args) - | Ucatch (n, ids, body, handler) -> + | Ucatch (n, vars, body, handler) -> let body = substitute_let_moveable is_let_moveable env body in let handler = substitute_let_moveable is_let_moveable env handler in - Ucatch (n, ids, body, handler) - | Utrywith (body, id, handler) -> + Ucatch (n, vars, body, handler) + | Utrywith (body, var, handler) -> let body = substitute_let_moveable is_let_moveable env body in let handler = substitute_let_moveable is_let_moveable env handler in - Utrywith (body, id, handler) + Utrywith (body, var, handler) | Uifthenelse (cond, ifso, ifnot) -> let cond = substitute_let_moveable is_let_moveable env cond in let ifso = substitute_let_moveable is_let_moveable env ifso in @@ -500,14 +505,14 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) let cond = substitute_let_moveable is_let_moveable env cond in let body = substitute_let_moveable is_let_moveable env body in Uwhile (cond, body) - | Ufor (id, low, high, direction, body) -> + | Ufor (var, low, high, direction, body) -> let low = substitute_let_moveable is_let_moveable env low in let high = substitute_let_moveable is_let_moveable env high in let body = substitute_let_moveable is_let_moveable env body in - Ufor (id, low, high, direction, body) - | Uassign (id, expr) -> + Ufor (var, low, high, direction, body) + | Uassign (var, expr) -> let expr = substitute_let_moveable is_let_moveable env expr in - Uassign (id, expr) + Uassign (var, expr) | Usend (kind, e1, e2, args, dbg) -> let e1 = substitute_let_moveable is_let_moveable env e1 in let e2 = substitute_let_moveable is_let_moveable env e2 in @@ -541,7 +546,7 @@ let both_moveable a b = let primitive_moveable (prim : Lambda.primitive) (args : Clambda.ulambda list) - (ident_info : ident_info) = + (var_info : var_info) = match prim, args with | Pfield _, [Uconst (Uconst_ref (_, _))] -> (* CR-someday mshinwell: Actually, maybe this shouldn't be needed; these @@ -551,7 +556,7 @@ let primitive_moveable (prim : Lambda.primitive) (* Allow field access of symbols to be moveable. (The comment in flambda.mli on [Read_symbol_field] may be helpful to the reader.) *) Moveable - | Pfield _, [Uvar id] when Ident.Set.mem id ident_info.closure_environment -> + | Pfield _, [Uvar var] when V.Set.mem var var_info.closure_environment -> (* accesses to the function environment is coeffect free: this block is never mutated *) Moveable @@ -568,16 +573,16 @@ type moveable_for_env = Constant | Moveable (** Eliminate, through substitution, [let]-bindings of linear variables with moveable defining expressions. *) -let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda) +let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) : Clambda.ulambda * moveable = match clam with - | Uvar id -> - begin match Ident.Map.find id env with + | Uvar var -> + begin match V.Map.find var env with | Constant, def -> def, Constant | Moveable, def -> def, Moveable | exception Not_found -> let moveable : moveable = - if Ident.Set.mem id ident_info.assigned then + if V.Set.mem var var_info.assigned then Fixed else Moveable @@ -588,163 +593,164 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda) (* Constant closures are rewritten separately. *) clam, Constant | Udirect_apply (label, args, dbg) -> - let args = un_anf_list ident_info env args in + let args = un_anf_list var_info env args in Udirect_apply (label, args, dbg), Fixed | Ugeneric_apply (func, args, dbg) -> - let func = un_anf ident_info env func in - let args = un_anf_list ident_info env args in + let func = un_anf var_info env func in + let args = un_anf_list var_info env args in Ugeneric_apply (func, args, dbg), Fixed | Uclosure (functions, variables_bound_by_the_closure) -> let functions = List.map (fun (ufunction : Clambda.ufunction) -> { ufunction with - body = un_anf ident_info env ufunction.body; + body = un_anf var_info env ufunction.body; }) functions in let variables_bound_by_the_closure = - un_anf_list ident_info env variables_bound_by_the_closure + un_anf_list var_info env variables_bound_by_the_closure in Uclosure (functions, variables_bound_by_the_closure), Fixed | Uoffset (clam, n) -> - let clam, moveable = un_anf_and_moveable ident_info env clam in + let clam, moveable = un_anf_and_moveable var_info env clam in Uoffset (clam, n), both_moveable Moveable moveable - | Ulet (_let_kind, _value_kind, id, def, Uvar id') when Ident.same id id' -> - un_anf_and_moveable ident_info env def - | Ulet (let_kind, value_kind, id, def, body) -> - let def, def_moveable = un_anf_and_moveable ident_info env def in - let is_linear = Ident.Set.mem id ident_info.linear in - let is_used = Ident.Set.mem id ident_info.used in - let is_assigned = Ident.Set.mem id ident_info.assigned in + | Ulet (_let_kind, _value_kind, var, def, Uvar var') + when V.same (VP.var var) var' -> + un_anf_and_moveable var_info env def + | Ulet (let_kind, value_kind, var, def, body) -> + let def, def_moveable = un_anf_and_moveable var_info env def in + let is_linear = V.Set.mem (VP.var var) var_info.linear in + let is_used = V.Set.mem (VP.var var) var_info.used in + let is_assigned = V.Set.mem (VP.var var) var_info.assigned in begin match def_moveable, is_linear, is_used, is_assigned with | (Constant | Moveable), _, false, _ -> (* A moveable expression that is never used may be eliminated. *) - un_anf_and_moveable ident_info env body + un_anf_and_moveable var_info env body | Constant, _, true, false - (* A constant expression bound to an unassigned identifier can replace any - occurrences of the identifier. *) + (* A constant expression bound to an unassigned variable can replace any + occurrences of the variable. *) | Moveable, true, true, false -> - (* A moveable expression bound to a linear unassigned [Ident.t] - may replace the single occurrence of the identifier. *) + (* A moveable expression bound to a linear unassigned [V.t] + may replace the single occurrence of the variable. *) let def_moveable = match def_moveable with | Moveable -> Moveable | Constant -> Constant | Fixed -> assert false in - let env = Ident.Map.add id (def_moveable, def) env in - un_anf_and_moveable ident_info env body + let env = V.Map.add (VP.var var) (def_moveable, def) env in + un_anf_and_moveable var_info env body | (Constant | Moveable), _, _, true (* Constant or Moveable but assigned. *) | Moveable, false, _, _ (* Moveable but not used linearly. *) | Fixed, _, _, _ -> - let body, body_moveable = un_anf_and_moveable ident_info env body in - Ulet (let_kind, value_kind, id, def, body), + let body, body_moveable = un_anf_and_moveable var_info env body in + Ulet (let_kind, value_kind, var, def, body), both_moveable def_moveable body_moveable end | Uletrec (defs, body) -> let defs = - List.map (fun (id, def) -> id, un_anf ident_info env def) defs + List.map (fun (var, def) -> var, un_anf var_info env def) defs in - let body = un_anf ident_info env body in + let body = un_anf var_info env body in Uletrec (defs, body), Fixed | Uprim (prim, args, dbg) -> - let args, args_moveable = un_anf_list_and_moveable ident_info env args in + let args, args_moveable = un_anf_list_and_moveable var_info env args in let moveable = - both_moveable args_moveable (primitive_moveable prim args ident_info) + both_moveable args_moveable (primitive_moveable prim args var_info) in Uprim (prim, args, dbg), moveable | Uswitch (cond, sw, dbg) -> - let cond = un_anf ident_info env cond in + let cond = un_anf var_info env cond in let sw = { sw with - us_actions_consts = un_anf_array ident_info env sw.us_actions_consts; - us_actions_blocks = un_anf_array ident_info env sw.us_actions_blocks; + us_actions_consts = un_anf_array var_info env sw.us_actions_consts; + us_actions_blocks = un_anf_array var_info env sw.us_actions_blocks; } in Uswitch (cond, sw, dbg), Fixed | Ustringswitch (cond, branches, default) -> - let cond = un_anf ident_info env cond in + let cond = un_anf var_info env cond in let branches = - List.map (fun (s, branch) -> s, un_anf ident_info env branch) + List.map (fun (s, branch) -> s, un_anf var_info env branch) branches in - let default = Misc.may_map (un_anf ident_info env) default in + let default = Misc.may_map (un_anf var_info env) default in Ustringswitch (cond, branches, default), Fixed | Ustaticfail (n, args) -> - let args = un_anf_list ident_info env args in + let args = un_anf_list var_info env args in Ustaticfail (n, args), Fixed - | Ucatch (n, ids, body, handler) -> - let body = un_anf ident_info env body in - let handler = un_anf ident_info env handler in - Ucatch (n, ids, body, handler), Fixed - | Utrywith (body, id, handler) -> - let body = un_anf ident_info env body in - let handler = un_anf ident_info env handler in - Utrywith (body, id, handler), Fixed + | Ucatch (n, vars, body, handler) -> + let body = un_anf var_info env body in + let handler = un_anf var_info env handler in + Ucatch (n, vars, body, handler), Fixed + | Utrywith (body, var, handler) -> + let body = un_anf var_info env body in + let handler = un_anf var_info env handler in + Utrywith (body, var, handler), Fixed | Uifthenelse (cond, ifso, ifnot) -> - let cond, cond_moveable = un_anf_and_moveable ident_info env cond in - let ifso, ifso_moveable = un_anf_and_moveable ident_info env ifso in - let ifnot, ifnot_moveable = un_anf_and_moveable ident_info env ifnot in + let cond, cond_moveable = un_anf_and_moveable var_info env cond in + let ifso, ifso_moveable = un_anf_and_moveable var_info env ifso in + let ifnot, ifnot_moveable = un_anf_and_moveable var_info env ifnot in let moveable = both_moveable cond_moveable (both_moveable ifso_moveable ifnot_moveable) in Uifthenelse (cond, ifso, ifnot), moveable | Usequence (e1, e2) -> - let e1 = un_anf ident_info env e1 in - let e2 = un_anf ident_info env e2 in + let e1 = un_anf var_info env e1 in + let e2 = un_anf var_info env e2 in Usequence (e1, e2), Fixed | Uwhile (cond, body) -> - let cond = un_anf ident_info env cond in - let body = un_anf ident_info env body in + let cond = un_anf var_info env cond in + let body = un_anf var_info env body in Uwhile (cond, body), Fixed - | Ufor (id, low, high, direction, body) -> - let low = un_anf ident_info env low in - let high = un_anf ident_info env high in - let body = un_anf ident_info env body in - Ufor (id, low, high, direction, body), Fixed - | Uassign (id, expr) -> - let expr = un_anf ident_info env expr in - Uassign (id, expr), Fixed + | Ufor (var, low, high, direction, body) -> + let low = un_anf var_info env low in + let high = un_anf var_info env high in + let body = un_anf var_info env body in + Ufor (var, low, high, direction, body), Fixed + | Uassign (var, expr) -> + let expr = un_anf var_info env expr in + Uassign (var, expr), Fixed | Usend (kind, e1, e2, args, dbg) -> - let e1 = un_anf ident_info env e1 in - let e2 = un_anf ident_info env e2 in - let args = un_anf_list ident_info env args in + let e1 = un_anf var_info env e1 in + let e2 = un_anf var_info env e2 in + let args = un_anf_list var_info env args in Usend (kind, e1, e2, args, dbg), Fixed | Uunreachable -> Uunreachable, Fixed -and un_anf ident_info env clam : Clambda.ulambda = - let clam, _moveable = un_anf_and_moveable ident_info env clam in +and un_anf var_info env clam : Clambda.ulambda = + let clam, _moveable = un_anf_and_moveable var_info env clam in clam -and un_anf_list_and_moveable ident_info env clams +and un_anf_list_and_moveable var_info env clams : Clambda.ulambda list * moveable = List.fold_right (fun clam (l, acc_moveable) -> - let clam, moveable = un_anf_and_moveable ident_info env clam in + let clam, moveable = un_anf_and_moveable var_info env clam in clam :: l, both_moveable moveable acc_moveable) clams ([], (Moveable : moveable)) -and un_anf_list ident_info env clams : Clambda.ulambda list = - let clams, _moveable = un_anf_list_and_moveable ident_info env clams in +and un_anf_list var_info env clams : Clambda.ulambda list = + let clams, _moveable = un_anf_list_and_moveable var_info env clams in clams -and un_anf_array ident_info env clams : Clambda.ulambda array = - Array.map (un_anf ident_info env) clams +and un_anf_array var_info env clams : Clambda.ulambda array = + Array.map (un_anf var_info env) clams let apply ~ppf_dump clam ~what = - let ident_info = make_ident_info clam in + let var_info = make_var_info clam in let let_bound_vars_that_can_be_moved = - let_bound_vars_that_can_be_moved ident_info clam + let_bound_vars_that_can_be_moved var_info clam in let clam = substitute_let_moveable let_bound_vars_that_can_be_moved - Ident.Map.empty clam + V.Map.empty clam in - let ident_info = make_ident_info clam in - let clam = un_anf ident_info Ident.Map.empty clam in + let var_info = make_var_info clam in + let clam = un_anf var_info V.Map.empty clam in if !Clflags.dump_clambda then begin Format.fprintf ppf_dump "@.un-anf (%s):@ %a@." what Printclambda.clambda clam diff --git a/testsuite/tools/parsecmmaux.ml b/testsuite/tools/parsecmmaux.ml index 6a66fc3a8..c2fb75658 100644 --- a/testsuite/tools/parsecmmaux.ml +++ b/testsuite/tools/parsecmmaux.ml @@ -20,7 +20,7 @@ type error = exception Error of error -let tbl_ident = (Hashtbl.create 57 : (string, Ident.t) Hashtbl.t) +let tbl_ident = (Hashtbl.create 57 : (string, Backend_var.t) Hashtbl.t) let tbl_label = (Hashtbl.create 57 : (string, int) Hashtbl.t) let ident_name s = @@ -29,9 +29,9 @@ let ident_name s = | n -> String.sub s 0 n let bind_ident s = - let id = Ident.create_local (ident_name s) in + let id = Backend_var.create_local (ident_name s) in Hashtbl.add tbl_ident s id; - id + Backend_var.With_provenance.create id let find_ident s = try @@ -40,7 +40,7 @@ let find_ident s = raise(Error(Unbound s)) let unbind_ident id = - Hashtbl.remove tbl_ident (Ident.name id) + Hashtbl.remove tbl_ident (Backend_var.With_provenance.name id) let find_label s = try diff --git a/testsuite/tools/parsecmmaux.mli b/testsuite/tools/parsecmmaux.mli index 7d4eeda80..a6728b494 100644 --- a/testsuite/tools/parsecmmaux.mli +++ b/testsuite/tools/parsecmmaux.mli @@ -15,9 +15,9 @@ (* Auxiliary functions for parsing *) -val bind_ident: string -> Ident.t -val find_ident: string -> Ident.t -val unbind_ident: Ident.t -> unit +val bind_ident: string -> Backend_var.With_provenance.t +val find_ident: string -> Backend_var.t +val unbind_ident: Backend_var.With_provenance.t -> unit val find_label: string -> int diff --git a/tools/Makefile b/tools/Makefile index 9fef1a692..158ac58bc 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -327,6 +327,7 @@ objinfo_helper$(EXE): objinfo_helper.c $(ROOTDIR)/runtime/caml/s.h OBJINFO=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ $(ROOTDIR)/compilerlibs/ocamlmiddleend.cma \ + $(ROOTDIR)/asmcomp/backend_var.cmo \ $(ROOTDIR)/asmcomp/printclambda.cmo \ $(ROOTDIR)/asmcomp/export_info.cmo \ objinfo.cmo @@ -347,6 +348,7 @@ $(call byte_and_opt,primreq,$(primreq),) LINTAPIDIFF=$(ROOTDIR)/compilerlibs/ocamlcommon.cmxa \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cmxa \ $(ROOTDIR)/compilerlibs/ocamlmiddleend.cmxa \ + $(ROOTDIR)/asmcomp/backend_var.cmx \ $(ROOTDIR)/asmcomp/printclambda.cmx \ $(ROOTDIR)/asmcomp/export_info.cmx \ $(ROOTDIR)/otherlibs/str/str.cmxa \