GPR#2056 (Backend_var)
Mark Shinwell
Pierre Chambart
parent
ccae1e2876
commit
2b5f13c913
184
.depend
184
.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 \
|
||||
|
|
|
|||
4
Changes
4
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
|
||||
|
|
|
|||
1
Makefile
1
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 \
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 "@[<hov 1>(\
|
||||
@[<hov 1>(module_path@ %a)@]@ \
|
||||
@[<hov 1>(location@ %a)@]@ \
|
||||
@[<hov 1>(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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 *)
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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 *)
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ())
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 = [];
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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@ @[<hv 1>(@[<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@ (@[<hv 1>%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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
Loading…
Reference in New Issue