diff options
75 files changed, 1300 insertions, 553 deletions
@@ -252,11 +252,11 @@ typing/types.cmx: typing/primitive.cmx typing/path.cmx utils/misc.cmx \ typing/typetexp.cmo: utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/env.cmi \ - typing/ctype.cmi typing/btype.cmi typing/typetexp.cmi + typing/ctype.cmi utils/clflags.cmi typing/btype.cmi typing/typetexp.cmi typing/typetexp.cmx: utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/env.cmx \ - typing/ctype.cmx typing/btype.cmx typing/typetexp.cmi + typing/ctype.cmx utils/clflags.cmx typing/btype.cmx typing/typetexp.cmi typing/unused_var.cmo: utils/warnings.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ typing/unused_var.cmi @@ -441,25 +441,28 @@ bytecomp/typeopt.cmx: typing/types.cmx typing/typedtree.cmx \ asmcomp/asmgen.cmi: bytecomp/lambda.cmi asmcomp/cmm.cmi asmcomp/asmlink.cmi: asmcomp/compilenv.cmi asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \ - parsing/asttypes.cmi + asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi -asmcomp/cmm.cmi: typing/ident.cmi asmcomp/cmmgen.cmi: asmcomp/cmm.cmi asmcomp/clambda.cmi +asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/codegen.cmi: asmcomp/cmm.cmi asmcomp/comballoc.cmi: asmcomp/mach.cmi asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/clambda.cmi +asmcomp/debuginfo.cmi: parsing/location.cmi bytecomp/lambda.cmi +asmcomp/emitaux.cmi: asmcomp/debuginfo.cmi asmcomp/emit.cmi: asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/interf.cmi: asmcomp/mach.cmi -asmcomp/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/liveness.cmi: asmcomp/mach.cmi -asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/cmm.cmi asmcomp/arch.cmo +asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo asmcomp/printcmm.cmi: asmcomp/cmm.cmi asmcomp/printlinear.cmi: asmcomp/linearize.cmi asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/proc.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/reg.cmi: asmcomp/cmm.cmi -asmcomp/reload.cmi: asmcomp/mach.cmi asmcomp/reloadgen.cmi: asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/reload.cmi: asmcomp/mach.cmi asmcomp/schedgen.cmi: asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/scheduling.cmi: asmcomp/linearize.cmi asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ @@ -467,8 +470,6 @@ asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ asmcomp/selection.cmi: asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/spill.cmi: asmcomp/mach.cmi asmcomp/split.cmi: asmcomp/mach.cmi -asmcomp/arch.cmo: utils/misc.cmi utils/config.cmi -asmcomp/arch.cmx: utils/misc.cmx utils/config.cmx asmcomp/asmgen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/selection.cmi \ asmcomp/scheduling.cmi asmcomp/reload.cmi asmcomp/reg.cmi \ asmcomp/proc.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \ @@ -512,29 +513,31 @@ asmcomp/asmpackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \ asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ asmcomp/asmgen.cmx asmcomp/asmpackager.cmi asmcomp/clambda.cmo: bytecomp/lambda.cmi typing/ident.cmi \ - parsing/asttypes.cmi asmcomp/clambda.cmi + asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi asmcomp/clambda.cmx: bytecomp/lambda.cmx typing/ident.cmx \ - parsing/asttypes.cmi asmcomp/clambda.cmi + asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi asmcomp/closure.cmo: utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \ - utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/compilenv.cmi \ - utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ - asmcomp/closure.cmi + utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ + asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \ + parsing/asttypes.cmi asmcomp/closure.cmi asmcomp/closure.cmx: utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ - utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/compilenv.cmx \ - utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ - asmcomp/closure.cmi -asmcomp/cmm.cmo: typing/ident.cmi asmcomp/arch.cmo asmcomp/cmm.cmi -asmcomp/cmm.cmx: typing/ident.cmx asmcomp/arch.cmx asmcomp/cmm.cmi + utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ + asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \ + parsing/asttypes.cmi asmcomp/closure.cmi asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \ typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ - utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi \ - asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ - asmcomp/cmmgen.cmi + asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/clambda.cmi \ + parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/cmmgen.cmi asmcomp/cmmgen.cmx: typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \ typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \ - utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx \ - asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ - asmcomp/cmmgen.cmi + asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/clambda.cmx \ + parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/cmmgen.cmi +asmcomp/cmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \ + asmcomp/cmm.cmi +asmcomp/cmm.cmx: typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \ + asmcomp/cmm.cmi asmcomp/codegen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \ asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \ asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \ @@ -555,76 +558,90 @@ asmcomp/compilenv.cmo: utils/misc.cmi typing/ident.cmi typing/env.cmi \ utils/config.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi asmcomp/compilenv.cmx: utils/misc.cmx typing/ident.cmx typing/env.cmx \ utils/config.cmx asmcomp/clambda.cmx asmcomp/compilenv.cmi +asmcomp/debuginfo.cmo: parsing/location.cmi bytecomp/lambda.cmi \ + asmcomp/debuginfo.cmi +asmcomp/debuginfo.cmx: parsing/location.cmx bytecomp/lambda.cmx \ + asmcomp/debuginfo.cmi +asmcomp/emitaux.cmo: asmcomp/reg.cmi asmcomp/linearize.cmi \ + asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/emitaux.cmi +asmcomp/emitaux.cmx: asmcomp/reg.cmx asmcomp/linearize.cmx \ + asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/emitaux.cmi asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi parsing/location.cmi asmcomp/linearize.cmi \ - asmcomp/emitaux.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/emit.cmi + asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \ + asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emit.cmi asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ - asmcomp/mach.cmx parsing/location.cmx asmcomp/linearize.cmx \ - asmcomp/emitaux.cmx utils/config.cmx asmcomp/compilenv.cmx \ - asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/emit.cmi -asmcomp/emitaux.cmo: asmcomp/emitaux.cmi -asmcomp/emitaux.cmx: asmcomp/emitaux.cmi + asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \ + asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/interf.cmi asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/interf.cmi asmcomp/linearize.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/linearize.cmi + asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/linearize.cmi asmcomp/linearize.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/linearize.cmi + asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ + asmcomp/linearize.cmi asmcomp/liveness.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi asmcomp/liveness.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmi -asmcomp/mach.cmo: asmcomp/reg.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/mach.cmi -asmcomp/mach.cmx: asmcomp/reg.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/mach.cmi -asmcomp/printcmm.cmo: typing/ident.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi -asmcomp/printcmm.cmx: typing/ident.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi +asmcomp/mach.cmo: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo asmcomp/mach.cmi +asmcomp/mach.cmx: asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ + asmcomp/arch.cmx asmcomp/mach.cmi +asmcomp/printcmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/printcmm.cmi +asmcomp/printcmm.cmx: typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ + asmcomp/printcmm.cmi asmcomp/printlinear.cmo: asmcomp/printmach.cmi asmcomp/mach.cmi \ - asmcomp/linearize.cmi asmcomp/printlinear.cmi + asmcomp/linearize.cmi asmcomp/debuginfo.cmi asmcomp/printlinear.cmi asmcomp/printlinear.cmx: asmcomp/printmach.cmx asmcomp/mach.cmx \ - asmcomp/linearize.cmx asmcomp/printlinear.cmi + asmcomp/linearize.cmx asmcomp/debuginfo.cmx asmcomp/printlinear.cmi asmcomp/printmach.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printcmm.cmi \ - asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi + asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/printmach.cmi asmcomp/printmach.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx \ - asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi + asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/printmach.cmi asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ - utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \ - asmcomp/arch.cmo asmcomp/proc.cmi + asmcomp/cmm.cmi utils/ccomp.cmi asmcomp/arch.cmo asmcomp/proc.cmi asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ - utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \ - asmcomp/arch.cmx asmcomp/proc.cmi + asmcomp/cmm.cmx utils/ccomp.cmx asmcomp/arch.cmx asmcomp/proc.cmi asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi -asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi -asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/reloadgen.cmi asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/reloadgen.cmi +asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi +asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ asmcomp/schedgen.cmi asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/schedgen.cmi -asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/mach.cmi \ - asmcomp/arch.cmo asmcomp/scheduling.cmi -asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/mach.cmx \ - asmcomp/arch.cmx asmcomp/scheduling.cmi +asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi +asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo asmcomp/selectgen.cmi asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/cmm.cmx \ asmcomp/arch.cmx asmcomp/selectgen.cmi -asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selection.cmi -asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selection.cmi +asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ + utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/selection.cmi +asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ + utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/selection.cmi asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/spill.cmi asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ @@ -663,6 +680,8 @@ driver/errors.cmx: utils/warnings.cmx typing/typetexp.cmx typing/typemod.cmx \ parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \ bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi +driver/main_args.cmo: driver/main_args.cmi +driver/main_args.cmx: driver/main_args.cmi driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \ driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmi \ bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ @@ -671,8 +690,6 @@ driver/main.cmx: utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \ driver/errors.cmx utils/config.cmx driver/compile.cmx utils/clflags.cmx \ bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ bytecomp/bytelibrarian.cmx driver/main.cmi -driver/main_args.cmo: driver/main_args.cmi -driver/main_args.cmx: driver/main_args.cmi driver/optcompile.cmo: utils/warnings.cmi typing/unused_var.cmi \ typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \ bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ @@ -68,7 +68,8 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo -ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \ +ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ + asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/cmmgen.cmo \ diff --git a/Makefile.nt b/Makefile.nt index 7dedd2568..3b29b3c6c 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -64,7 +64,8 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo -ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \ +ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ + asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/cmmgen.cmo \ diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index ea9363e7b..4f2d54d17 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -131,16 +131,9 @@ let emit_addressing addr r n = if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` -(* Record live pointers at call points *) +(* Record live pointers at call points -- see Emitaux *) -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = +let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter @@ -154,21 +147,12 @@ let record_frame_label live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:\n` - -let emit_frame fd = - ` .quad {emit_label fd.fd_lbl}\n`; - ` .word {emit_int fd.fd_frame_size}\n`; - ` .word {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .word {emit_int n}\n`) - fd.fd_live_offset; - emit_align 8 +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) @@ -183,6 +167,38 @@ let emit_call_gc gc = `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` +(* Record calls to caml_ml_array_bound_error. + In -g mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Without -g, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: call {emit_symbol "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then + `{emit_label !bound_error_call}: jmp {emit_symbol "caml_ml_array_bound_error"}\n` + (* Names for instructions *) let instr_for_intop = function @@ -277,8 +293,6 @@ let output_epilogue () = let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -(* Label of trap for out-of-range accesses *) -let range_check_trap = ref 0 let float_constants = ref ([] : (int * string) list) @@ -318,10 +332,10 @@ let emit_instr fallthrough i = ` movq ${emit_symbol s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> ` call *{emit_reg i.arg.(0)}\n`; - record_frame i.live - | Lop(Icall_imm s) -> + record_frame i.live i.dbg + | Lop(Icall_imm(s)) -> ` call {emit_symbol s}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); ` jmp *{emit_reg i.arg.(0)}\n` @@ -336,7 +350,7 @@ let emit_instr fallthrough i = if alloc then begin ` leaq {emit_symbol s}(%rip), %rax\n`; ` call {emit_symbol "caml_c_call"}\n`; - record_frame i.live + record_frame i.live i.dbg end else begin ` call {emit_symbol s}\n` end @@ -389,7 +403,7 @@ let emit_instr fallthrough i = `{emit_label lbl_redo}: subq ${emit_int n}, %r15\n`; ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\n`; let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live in + let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` leaq 8(%r15), {emit_reg i.res.(0)}\n`; call_gc_sites := @@ -404,7 +418,7 @@ let emit_instr fallthrough i = | _ -> ` movq ${emit_int n}, %rax\n`; ` call {emit_symbol "caml_allocN"}\n` end; - `{record_frame i.live} leaq 8(%r15), {emit_reg i.res.(0)}\n` + `{record_frame i.live Debuginfo.none} leaq 8(%r15), {emit_reg i.res.(0)}\n` end | Lop(Iintop(Icomp cmp)) -> ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; @@ -417,13 +431,13 @@ let emit_instr fallthrough i = ` set{emit_string b} %al\n`; ` movzbq %al, {emit_reg i.res.(0)}\n` | Lop(Iintop Icheckbound) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cqto\n`; ` idivq {emit_reg i.arg.(1)}\n` @@ -558,9 +572,14 @@ let emit_instr fallthrough i = ` addq $8, %rsp\n`; stack_offset := !stack_offset - 16 | Lraise -> - ` movq %r14, %rsp\n`; - ` popq %r14\n`; - ` ret\n` + if !Clflags.debug then begin + ` call {emit_symbol "caml_raise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` movq %r14, %rsp\n`; + ` popq %r14\n`; + ` ret\n` + end let rec emit_all fallthrough i = match i.desc with @@ -601,7 +620,8 @@ let fundecl fundecl = stack_offset := 0; float_constants := []; call_gc_sites := []; - range_check_trap := 0; + bound_error_sites := []; + bound_error_call := 0; ` .text\n`; emit_align 16; ` .globl {emit_symbol fundecl.fun_name}\n`; @@ -614,9 +634,7 @@ let fundecl fundecl = `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; - if !range_check_trap > 0 then - `{emit_label !range_check_trap}: call {emit_symbol "caml_ml_array_bound_error"}\n`; - (* Never returns, but useful to have retaddr on stack for debugging *) + emit_call_bound_errors (); if !float_constants <> [] then begin ` .section .rodata.cst8,\"a\",@progbits\n`; List.iter emit_float_constant !float_constants @@ -683,6 +701,13 @@ let end_assembly() = let lbl = Compilenv.make_symbol (Some "frametable") in ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; - ` .quad {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] + emit_frames + { efa_label = (fun l -> ` .quad {emit_label l}\n`); + efa_16 = (fun n -> ` .word {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .quad {emit_int n}\n`); + efa_align = emit_align; + efa_label_rel = (fun lbl ofs -> + ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l}:\n`); + efa_string = (fun s -> emit_string_directive " .asciz " s) } diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 8faabb7ad..d28fbfb99 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -213,15 +213,18 @@ method select_floatarith commutative regular_op mem_op args = (* Deal with register constraints *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = try let (rsrc, rdst) = pseudoregs_for_operation op rs rd in self#insert_moves rs rsrc; - self#insert (Iop op) rsrc rdst; + self#insert_debug (Iop op) dbg rsrc rdst; self#insert_moves rdst rd; rd with Use_default -> - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd + +method insert_op op rs rd = + self#insert_op_debug op Debuginfo.none rs rd end diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 5b4464290..5e31c3bbb 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -23,14 +23,14 @@ type function_label = string type ulambda = Uvar of Ident.t | Uconst of structured_constant - | Udirect_apply of function_label * ulambda list - | Ugeneric_apply of ulambda * ulambda list + | Udirect_apply of function_label * ulambda list * Debuginfo.t + | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of (function_label * int * Ident.t list * ulambda) list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda - | Uprim of primitive * ulambda list + | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda @@ -40,7 +40,7 @@ type ulambda = | Uwhile of ulambda * ulambda | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda - | Usend of meth_kind * ulambda * ulambda * ulambda list + | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t and ulambda_switch = { us_index_consts: int array; diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 116d8c75a..724490c52 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -23,14 +23,14 @@ type function_label = string type ulambda = Uvar of Ident.t | Uconst of structured_constant - | Udirect_apply of function_label * ulambda list - | Ugeneric_apply of ulambda * ulambda list + | Udirect_apply of function_label * ulambda list * Debuginfo.t + | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of (function_label * int * Ident.t list * ulambda) list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda - | Uprim of primitive * ulambda list + | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda @@ -40,7 +40,7 @@ type ulambda = | Uwhile of ulambda * ulambda | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda - | Usend of meth_kind * ulambda * ulambda * ulambda list + | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t and ulambda_switch = { us_index_consts: int array; diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 216f27356..34a2a5a65 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -33,7 +33,7 @@ let rec split_list n l = let rec build_closure_env env_param pos = function [] -> Tbl.empty | id :: rem -> - Tbl.add id (Uprim(Pfield pos, [Uvar env_param])) + Tbl.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 @@ -43,7 +43,7 @@ let rec build_closure_env env_param pos = function let getglobal id = Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)), - []) + [], Debuginfo.none) (* Check if a variable occurs in a [clambda] term. *) @@ -51,14 +51,14 @@ let occurs_var var u = let rec occurs = function Uvar v -> v = var | Uconst cst -> false - | Udirect_apply(lbl, args) -> List.exists occurs args - | Ugeneric_apply(funct, args) -> occurs funct || List.exists occurs args + | Udirect_apply(lbl, args, _) -> List.exists occurs args + | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args | Uclosure(fundecls, clos) -> List.exists occurs clos | Uoffset(u, ofs) -> occurs u | Ulet(id, def, body) -> occurs def || occurs body | Uletrec(decls, body) -> List.exists (fun (id, u) -> occurs u) decls || occurs body - | Uprim(p, args) -> List.exists occurs args + | Uprim(p, args, _) -> List.exists occurs args | Uswitch(arg, s) -> occurs arg || occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks @@ -71,7 +71,7 @@ let occurs_var var u = | Uwhile(cond, body) -> occurs cond || occurs body | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body | Uassign(id, u) -> id = var || occurs u - | Usend(_, met, obj, args) -> + | Usend(_, met, obj, args, _) -> occurs met || occurs obj || List.exists occurs args and occurs_array a = try @@ -124,9 +124,9 @@ let lambda_smaller lam threshold = Const_pointer _) -> incr size | Uconst _ -> raise Exit (* avoid duplication of structured constants *) - | Udirect_apply(fn, args) -> + | Udirect_apply(fn, args, _) -> size := !size + 4; lambda_list_size args - | Ugeneric_apply(fn, args) -> + | Ugeneric_apply(fn, args, _) -> size := !size + 6; lambda_size fn; lambda_list_size args | Uclosure(defs, vars) -> raise Exit (* inlining would duplicate function definitions *) @@ -136,7 +136,7 @@ let lambda_smaller lam threshold = lambda_size lam; lambda_size body | Uletrec(bindings, body) -> raise Exit (* usually too large *) - | Uprim(prim, args) -> + | Uprim(prim, args, _) -> size := !size + prim_size prim args; lambda_list_size args | Uswitch(lam, cases) -> @@ -161,7 +161,7 @@ let lambda_smaller lam threshold = size := !size + 4; lambda_size low; lambda_size high; lambda_size body | Uassign(id, lam) -> incr size; lambda_size lam - | Usend(_, met, obj, args) -> + | Usend(_, met, obj, args, _) -> size := !size + 8; lambda_size met; lambda_size obj; lambda_list_size args and lambda_list_size l = List.iter lambda_size l @@ -179,8 +179,8 @@ let rec is_pure_clambda = function | Uconst cst -> true | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | - Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false - | Uprim(p, args) -> List.for_all is_pure_clambda args + Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false + | Uprim(p, args, _) -> List.for_all is_pure_clambda args | _ -> false (* Simplify primitive operations on integers *) @@ -189,14 +189,14 @@ let make_const_int n = (Uconst(Const_base(Const_int n)), Value_integer n) let make_const_ptr n = (Uconst(Const_pointer n), Value_constptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) -let simplif_prim_pure p (args, approxs) = +let simplif_prim_pure p (args, approxs) dbg = match approxs with [Value_integer x] -> begin match p with Pidentity -> make_const_int x | Pnegint -> make_const_int (-x) | Poffsetint y -> make_const_int (x + y) - | _ -> (Uprim(p, args), Value_unknown) + | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_integer x; Value_integer y] -> begin match p with @@ -220,28 +220,28 @@ let simplif_prim_pure p (args, approxs) = | Cle -> x <= y | Cge -> x >= y in make_const_bool result - | _ -> (Uprim(p, args), Value_unknown) + | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_constptr x] -> begin match p with Pidentity -> make_const_ptr x | Pnot -> make_const_bool(x = 0) | Pisint -> make_const_bool true - | _ -> (Uprim(p, args), Value_unknown) + | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_constptr x; Value_constptr y] -> begin match p with Psequand -> make_const_bool(x <> 0 && y <> 0) | Psequor -> make_const_bool(x <> 0 || y <> 0) - | _ -> (Uprim(p, args), Value_unknown) + | _ -> (Uprim(p, args, dbg), Value_unknown) end | _ -> - (Uprim(p, args), Value_unknown) + (Uprim(p, args, dbg), Value_unknown) -let simplif_prim p (args, approxs as args_approxs) = +let simplif_prim p (args, approxs as args_approxs) dbg = if List.for_all is_pure_clambda args - then simplif_prim_pure p args_approxs - else (Uprim(p, args), Value_unknown) + then simplif_prim_pure p args_approxs dbg + else (Uprim(p, args, dbg), Value_unknown) (* Substitute variables in a [ulambda] term (a body of an inlined function) and perform some more simplifications on integer primitives. @@ -263,10 +263,10 @@ let rec substitute sb ulam = Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end | Uconst cst -> ulam - | Udirect_apply(lbl, args) -> - Udirect_apply(lbl, List.map (substitute sb) args) - | Ugeneric_apply(fn, args) -> - Ugeneric_apply(substitute sb fn, List.map (substitute sb) args) + | Udirect_apply(lbl, args, dbg) -> + Udirect_apply(lbl, List.map (substitute sb) args, dbg) + | Ugeneric_apply(fn, args, dbg) -> + Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg) | Uclosure(defs, env) -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -291,9 +291,9 @@ let rec substitute sb ulam = Uletrec( List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1, substitute sb' body) - | Uprim(p, args) -> + | Uprim(p, args, dbg) -> let sargs = List.map (substitute sb) args in - let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) in + let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> Uswitch(substitute sb arg, @@ -330,8 +330,8 @@ let rec substitute sb ulam = with Not_found -> id in Uassign(id', substitute sb u) - | Usend(k, u1, u2, ul) -> - Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul) + | Usend(k, u1, u2, ul, dbg) -> + Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, dbg) (* Perform an inline expansion *) @@ -379,6 +379,7 @@ let rec is_pure = function Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _), _) -> false | Lprim(p, args) -> List.for_all is_pure args + | Levent(lam, ev) -> is_pure lam | _ -> false (* Generate a direct application *) @@ -388,7 +389,7 @@ let direct_apply fundesc funct ufunct uargs = if fundesc.fun_closed then uargs else uargs @ [ufunct] in let app = match fundesc.fun_inline with - None -> Udirect_apply(fundesc.fun_label, app_args) + None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) | Some(params, body) -> bind_params params app_args body in (* If ufunct can contain side-effects or function definitions, we must make sure that it is evaluated exactly once. @@ -431,6 +432,32 @@ let global_approx = ref([||] : value_approximation array) let function_nesting_depth = ref 0 let excessive_function_nesting_depth = 5 +(* Decorate clambda term with debug information *) + +let rec add_debug_info ev u = + match ev.lev_kind with + | Lev_after _ -> + begin match u with + | Udirect_apply(lbl, args, dinfo) -> + Udirect_apply(lbl, args, Debuginfo.from_call ev) + | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1), + args2, dinfo2) -> + Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev), + args2, Debuginfo.from_call ev) + | Ugeneric_apply(fn, args, dinfo) -> + Ugeneric_apply(fn, args, Debuginfo.from_call ev) + | Uprim(Praise, args, dinfo) -> + Uprim(Praise, args, Debuginfo.from_call ev) + | Uprim(p, args, dinfo) -> + Uprim(p, args, Debuginfo.from_call ev) + | Usend(kind, u1, u2, args, dinfo) -> + Usend(kind, u1, u2, args, Debuginfo.from_call ev) + | Usequence(u1, u2) -> + Usequence(u1, add_debug_info ev u2) + | _ -> u + end + | _ -> u + (* Uncurry an expression and explicitate closures. Also return the approximation of the expression. The approximation environment [fenv] maps idents to approximations. @@ -452,8 +479,6 @@ let close_approx_var fenv cenv id = let close_var fenv cenv id = let (ulam, app) = close_approx_var fenv cenv id in ulam -exception Found of int - let rec close fenv cenv = function Lvar id -> close_approx_var fenv cenv id @@ -470,7 +495,7 @@ let rec close fenv cenv = function let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with ((ufunct, Value_closure(fundesc, approx_res)), - [Uprim(Pmakeblock(_, _), uargs)]) + [Uprim(Pmakeblock(_, _), uargs, _)]) when List.length uargs = - fundesc.fun_arity -> let app = direct_apply fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) @@ -482,15 +507,16 @@ let rec close fenv cenv = function when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> let (first_args, rem_args) = split_list fundesc.fun_arity uargs in (Ugeneric_apply(direct_apply fundesc funct ufunct first_args, - rem_args), + rem_args, Debuginfo.none), Value_unknown) | ((ufunct, _), uargs) -> - (Ugeneric_apply(ufunct, uargs), Value_unknown) + (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown) end | Lsend(kind, met, obj, args) -> let (umet, _) = close fenv cenv met in let (uobj, _) = close fenv cenv obj in - (Usend(kind, umet, uobj, close_list fenv cenv args), Value_unknown) + (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none), + Value_unknown) | Llet(str, id, lam, body) -> let (ulam, alam) = close_named fenv cenv id lam in begin match (str, alam) with @@ -542,7 +568,7 @@ let rec close fenv cenv = function (Compilenv.global_approx id) | Lprim(Pmakeblock(tag, mut) as prim, lams) -> let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in - (Uprim(prim, ulams), + (Uprim(prim, ulams, Debuginfo.none), begin match mut with Immutable -> Value_tuple(Array.of_list approxs) | Mutable -> Value_unknown @@ -553,14 +579,18 @@ let rec close fenv cenv = function match approx with Value_tuple a when n < Array.length a -> a.(n) | _ -> Value_unknown in - check_constant_result lam (Uprim(Pfield n, [ulam])) fieldapprox + check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) fieldapprox | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) -> let (ulam, approx) = close fenv cenv lam in (!global_approx).(n) <- approx; - (Uprim(Psetfield(n, false), [getglobal id; ulam]), + (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none), + Value_unknown) + | Lprim(Praise, [Levent(arg, ev)]) -> + let (ulam, approx) = close fenv cenv arg in + (Uprim(Praise, [ulam], Debuginfo.from_raise ev), Value_unknown) | Lprim(p, args) -> - simplif_prim p (close_list_approx fenv cenv args) + simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none | Lswitch(arg, sw) -> (* NB: failaction might get copied, thus it should be some Lstaticraise *) let (uarg, _) = close fenv cenv arg in @@ -610,7 +640,11 @@ let rec close fenv cenv = function | Lassign(id, lam) -> let (ulam, _) = close fenv cenv lam in (Uassign(id, ulam), Value_unknown) - | Levent _ | Lifused _ -> assert false + | Levent(lam, ev) -> + let (ulam, approx) = close fenv cenv lam in + (add_debug_info ev ulam, approx) + | Lifused _ -> + assert false and close_list fenv cenv = function [] -> [] diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index c1e16cffc..8d817a857 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -67,8 +67,8 @@ type memory_chunk = | Double_u type operation = - Capply of machtype - | Cextcall of string * machtype * bool + Capply of machtype * Debuginfo.t + | Cextcall of string * machtype * bool * Debuginfo.t | Cload of memory_chunk | Calloc | Cstore of memory_chunk @@ -81,8 +81,8 @@ type operation = | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise - | Ccheckbound + | Craise of Debuginfo.t + | Ccheckbound of Debuginfo.t type expression = Cconst_int of int diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 2aadd65ca..5cabc0066 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -53,8 +53,8 @@ type memory_chunk = | Double_u (* word-aligned 64-bit float *) type operation = - Capply of machtype - | Cextcall of string * machtype * bool + Capply of machtype * Debuginfo.t + | Cextcall of string * machtype * bool * Debuginfo.t | Cload of memory_chunk | Calloc | Cstore of memory_chunk @@ -67,8 +67,8 @@ type operation = | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise - | Ccheckbound + | Craise of Debuginfo.t + | Ccheckbound of Debuginfo.t type expression = Cconst_int of int diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index b91a8c9b9..9d65ee9f5 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -159,14 +159,15 @@ let is_nonzero_constant = function | Cconst_natint n -> n <> 0n | _ -> false -let safe_divmod op c1 c2 = +let safe_divmod op c1 c2 dbg = if !Clflags.fast || is_nonzero_constant c2 then Cop(op, [c1; c2]) else bind "divisor" c2 (fun c2 -> Cifthenelse(c2, Cop(op, [c1; c2]), - Cop(Craise, [Cconst_symbol "caml_bucket_Division_by_zero"]))) + Cop(Craise dbg, + [Cconst_symbol "caml_bucket_Division_by_zero"]))) (* Bool *) @@ -211,10 +212,10 @@ let rec remove_unit = function Ctrywith(remove_unit body, exn, remove_unit handler) | Clet(id, c1, c2) -> Clet(id, c1, remove_unit c2) - | Cop(Capply mty, args) -> - Cop(Capply typ_void, args) - | Cop(Cextcall(proc, mty, alloc), args) -> - Cop(Cextcall(proc, typ_void, alloc), args) + | Cop(Capply (mty, dbg), args) -> + Cop(Capply (typ_void, dbg), args) + | Cop(Cextcall(proc, mty, alloc, dbg), args) -> + Cop(Cextcall(proc, typ_void, alloc, dbg), args) | Cexit (_,_) as c -> c | Ctuple [] as c -> c | c -> Csequence(c, Ctuple []) @@ -290,7 +291,7 @@ let float_array_ref arr ofs = box_float(unboxed_float_array_ref arr ofs) let addr_array_set arr ofs newval = - Cop(Cextcall("caml_modify", typ_void, false), + Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), [array_indexing log2_size_addr arr ofs; newval]) let int_array_set arr ofs newval = Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval]) @@ -317,18 +318,19 @@ let string_length exp = let lookup_tag obj tag = bind "tag" tag (fun tag -> - Cop(Cextcall("caml_get_public_method", typ_addr, false), [obj; tag])) + Cop(Cextcall("caml_get_public_method", typ_addr, false, Debuginfo.none), + [obj; tag])) let lookup_label obj lab = bind "lab" lab (fun lab -> let table = Cop (Cload Word, [obj]) in addr_array_ref table lab) -let call_cached_method obj tag cache pos args = +let call_cached_method obj tag cache pos args dbg = let arity = List.length args in let cache = array_indexing log2_size_addr cache pos in Compilenv.need_send_fun arity; - Cop(Capply typ_addr, + Cop(Capply (typ_addr, dbg), Cconst_symbol("caml_send" ^ string_of_int arity) :: obj :: tag :: cache :: args) @@ -344,7 +346,7 @@ let make_alloc_generic set_fn tag wordsize args = | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1, fill_fields (idx + 2) el) in Clet(id, - Cop(Cextcall("caml_alloc", typ_addr, true), + Cop(Cextcall("caml_alloc", typ_addr, true, Debuginfo.none), [Cconst_int wordsize; Cconst_int tag]), fill_fields 1 args) end @@ -376,9 +378,9 @@ let rec expr_size = function expr_size body | Uletrec(bindings, body) -> expr_size body - | Uprim(Pmakeblock(tag, mut), args) -> + | Uprim(Pmakeblock(tag, mut), args, _) -> RHS_block (List.length args) - | Uprim(Pmakearray(Paddrarray | Pintarray), args) -> + | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) -> RHS_block (List.length args) | Usequence(exp, exp') -> expr_size exp' @@ -505,14 +507,14 @@ let bigarray_elt_size = function | Pbigarray_complex32 -> 8 | Pbigarray_complex64 -> 16 -let bigarray_indexing elt_kind layout b args = +let bigarray_indexing elt_kind layout b args dbg = let rec ba_indexing dim_ofs delta_ofs = function [] -> assert false | [arg] -> bind "idx" (untag_int arg) (fun idx -> Csequence( - Cop(Ccheckbound, [Cop(Cload Word,[field_address b dim_ofs]); idx]), + Cop(Ccheckbound dbg, [Cop(Cload Word,[field_address b dim_ofs]); idx]), idx)) | arg1 :: argl -> let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in @@ -520,7 +522,7 @@ let bigarray_indexing elt_kind layout b args = (fun idx -> bind "bound" (Cop(Cload Word, [field_address b dim_ofs])) (fun bound -> - Csequence(Cop(Ccheckbound, [bound; idx]), + Csequence(Cop(Ccheckbound dbg, [bound; idx]), add_int (mul_int rem bound) idx))) in let offset = match layout with @@ -553,33 +555,33 @@ let bigarray_word_kind = function | Pbigarray_complex32 -> Single | Pbigarray_complex64 -> Double -let bigarray_get elt_kind layout b args = +let bigarray_get elt_kind layout b args dbg = match elt_kind with Pbigarray_complex32 | Pbigarray_complex64 -> let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in - bind "addr" (bigarray_indexing elt_kind layout b args) (fun addr -> + bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr -> box_complex (Cop(Cload kind, [addr])) (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) | _ -> Cop(Cload (bigarray_word_kind elt_kind), - [bigarray_indexing elt_kind layout b args]) + [bigarray_indexing elt_kind layout b args dbg]) -let bigarray_set elt_kind layout b args newval = +let bigarray_set elt_kind layout b args newval dbg = match elt_kind with Pbigarray_complex32 | Pbigarray_complex64 -> let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in bind "newval" newval (fun newv -> - bind "addr" (bigarray_indexing elt_kind layout b args) (fun addr -> + bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr -> Csequence( Cop(Cstore kind, [addr; complex_re newv]), Cop(Cstore kind, [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv])))) | _ -> Cop(Cstore (bigarray_word_kind elt_kind), - [bigarray_indexing elt_kind layout b args; newval]) + [bigarray_indexing elt_kind layout b args dbg; newval]) (* Simplification of some primitives into C calls *) @@ -698,7 +700,7 @@ type unboxed_number_kind = let is_unboxed_number = function Uconst(Const_base(Const_float f)) -> Boxed_float - | Uprim(p, _) -> + | Uprim(p, _, _) -> begin match simplif_primitive p with Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing | Pfloatfield _ -> Boxed_float @@ -808,23 +810,25 @@ let rec transl = function Cop(Calloc, transl_fundecls 0 fundecls) | Uoffset(arg, offset) -> field_address (transl arg) offset - | Udirect_apply(lbl, args) -> - Cop(Capply typ_addr, Cconst_symbol lbl :: List.map transl args) - | Ugeneric_apply(clos, [arg]) -> + | Udirect_apply(lbl, args, dbg) -> + Cop(Capply(typ_addr, dbg), Cconst_symbol lbl :: List.map transl args) + | Ugeneric_apply(clos, [arg], dbg) -> bind "fun" (transl clos) (fun clos -> - Cop(Capply typ_addr, [get_field clos 0; transl arg; clos])) - | Ugeneric_apply(clos, args) -> + Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos])) + | Ugeneric_apply(clos, args, dbg) -> let arity = List.length args in let cargs = Cconst_symbol(apply_function arity) :: List.map transl (args @ [clos]) in - Cop(Capply typ_addr, cargs) - | Usend(kind, met, obj, args) -> + Cop(Capply(typ_addr, dbg), cargs) + | Usend(kind, met, obj, args, dbg) -> let call_met obj args clos = - if args = [] then Cop(Capply typ_addr,[get_field clos 0;obj;clos]) else - let arity = List.length args + 1 in - let cargs = Cconst_symbol(apply_function arity) :: obj :: - (List.map transl args) @ [clos] in - Cop(Capply typ_addr, cargs) + if args = [] then + Cop(Capply(typ_addr, dbg), [get_field clos 0;obj;clos]) + else + let arity = List.length args + 1 in + let cargs = Cconst_symbol(apply_function arity) :: obj :: + (List.map transl args) @ [clos] in + Cop(Capply(typ_addr, dbg), cargs) in bind "obj" (transl obj) (fun obj -> match kind, args with @@ -832,7 +836,7 @@ let rec transl = function bind "met" (lookup_label obj (transl met)) (call_met obj args) | Cached, cache :: pos :: args -> call_cached_method obj (transl met) (transl cache) (transl pos) - (List.map transl args) + (List.map transl args) dbg | _ -> bind "met" (lookup_tag obj (transl met)) (call_met obj args)) | Ulet(id, exp, body) -> @@ -850,7 +854,7 @@ let rec transl = function transl_letrec bindings (transl body) (* Primitives *) - | Uprim(prim, args) -> + | Uprim(prim, args, dbg) -> begin match (simplif_primitive prim, args) with (Pgetglobal id, []) -> Cconst_symbol (Ident.name id) @@ -861,14 +865,14 @@ let rec transl = function | (Pccall prim, args) -> if prim.prim_native_float then box_float - (Cop(Cextcall(prim.prim_native_name, typ_float, false), + (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg), List.map transl_unbox_float args)) else begin let name = if prim.prim_native_name <> "" then prim.prim_native_name else prim.prim_name in - Cop(Cextcall(name, typ_addr, prim.prim_alloc), + Cop(Cextcall(name, typ_addr, prim.prim_alloc, dbg), List.map transl args) end | (Pmakearray kind, []) -> @@ -876,7 +880,7 @@ let rec transl = function | (Pmakearray kind, args) -> begin match kind with Pgenarray -> - Cop(Cextcall("caml_make_array", typ_addr, true), + Cop(Cextcall("caml_make_array", typ_addr, true, Debuginfo.none), [make_alloc 0 (List.map transl args)]) | Paddrarray | Pintarray -> make_alloc 0 (List.map transl args) @@ -887,7 +891,7 @@ let rec transl = function | (Pbigarrayref(num_dims, elt_kind, layout), arg1 :: argl) -> let elt = bigarray_get elt_kind layout - (transl arg1) (List.map transl argl) in + (transl arg1) (List.map transl argl) dbg in begin match elt_kind with Pbigarray_float32 | Pbigarray_float64 -> box_float elt | Pbigarray_complex32 | Pbigarray_complex64 -> elt @@ -909,13 +913,14 @@ let rec transl = function | Pbigarray_int32 -> transl_unbox_int Pint32 argnewval | Pbigarray_int64 -> transl_unbox_int Pint64 argnewval | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval - | _ -> untag_int (transl argnewval))) + | _ -> untag_int (transl argnewval)) + dbg) | (p, [arg]) -> - transl_prim_1 p arg + transl_prim_1 p arg dbg | (p, [arg1; arg2]) -> - transl_prim_2 p arg1 arg2 + transl_prim_2 p arg1 arg2 dbg | (p, [arg1; arg2; arg3]) -> - transl_prim_3 p arg1 arg2 arg3 + transl_prim_3 p arg1 arg2 arg3 dbg | (_, _) -> fatal_error "Cmmgen.transl:prim" end @@ -948,19 +953,19 @@ let rec transl = function Ccatch(nfail, ids, transl body, transl handler) | Utrywith(body, exn, handler) -> Ctrywith(transl body, exn, transl handler) - | Uifthenelse(Uprim(Pnot, [arg]), ifso, ifnot) -> + | Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) -> transl (Uifthenelse(arg, ifnot, ifso)) | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) -> exit_if_false cond (transl ifso) nfail | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) -> exit_if_true cond nfail (transl ifnot) - | Uifthenelse(Uprim(Psequand, _) as cond, ifso, ifnot) -> + | Uifthenelse(Uprim(Psequand, _, _) as cond, ifso, ifnot) -> let raise_num = next_raise_count () in make_catch raise_num (exit_if_false cond (transl ifso) raise_num) (transl ifnot) - | Uifthenelse(Uprim(Psequor, _) as cond, ifso, ifnot) -> + | Uifthenelse(Uprim(Psequor, _, _) as cond, ifso, ifnot) -> let raise_num = next_raise_count () in make_catch raise_num @@ -1016,7 +1021,7 @@ let rec transl = function | Uassign(id, exp) -> return_unit(Cassign(id, transl exp)) -and transl_prim_1 p arg = +and transl_prim_1 p arg dbg = match p with (* Generic operations *) Pidentity -> @@ -1034,7 +1039,7 @@ and transl_prim_1 p arg = else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) (* Exceptions *) | Praise -> - Cop(Craise, [transl arg]) + Cop(Craise dbg, [transl arg]) (* Integer operations *) | Pnegint -> Cop(Csubi, [Cconst_int 2; transl arg]) @@ -1042,7 +1047,7 @@ and transl_prim_1 p arg = if no_overflow_lsl n then add_const (transl arg) (n lsl 1) else - transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) + transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) Debuginfo.none | Poffsetref n -> return_unit (bind "ref" (transl arg) (fun arg -> @@ -1096,12 +1101,12 @@ and transl_prim_1 p arg = | _ -> fatal_error "Cmmgen.transl_prim_1" -and transl_prim_2 p arg1 arg2 = +and transl_prim_2 p arg1 arg2 dbg = match p with (* Heap operations *) Psetfield(n, ptr) -> if ptr then - return_unit(Cop(Cextcall("caml_modify", typ_void, false), + return_unit(Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), [field_address (transl arg1) n; transl arg2])) else return_unit(set_field (transl arg1) n (transl arg2)) @@ -1130,9 +1135,9 @@ and transl_prim_2 p arg1 arg2 = | Pmulint -> incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])) | Pdivint -> - tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2))) + tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pmodint -> - tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2))) + tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pandint -> Cop(Cand, [transl arg1; transl arg2]) | Porint -> @@ -1179,7 +1184,7 @@ and transl_prim_2 p arg1 arg2 = (bind "str" (transl arg1) (fun str -> bind "index" (untag_int (transl arg2)) (fun idx -> Csequence( - Cop(Ccheckbound, [string_length str; idx]), + Cop(Ccheckbound dbg, [string_length str; idx]), Cop(Cload Byte_unsigned, [add_int str idx]))))) (* Array operations *) @@ -1203,20 +1208,20 @@ and transl_prim_2 p arg1 arg2 = bind "arr" (transl arg1) (fun arr -> bind "header" (header arr) (fun hdr -> Cifthenelse(is_addr_array_hdr hdr, - Csequence(Cop(Ccheckbound, [addr_array_length hdr; idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]), addr_array_ref arr idx), - Csequence(Cop(Ccheckbound, [float_array_length hdr; idx]), + Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]), float_array_ref arr idx))))) | Paddrarray | Pintarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, [addr_array_length(header arr); idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]), addr_array_ref arr idx))) | Pfloatarray -> box_float( bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, + Csequence(Cop(Ccheckbound dbg, [float_array_length(header arr); idx]), unboxed_float_array_ref arr idx)))) end @@ -1243,10 +1248,12 @@ and transl_prim_2 p arg1 arg2 = [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Pdivbint bi -> box_int bi (safe_divmod Cdivi - (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)) + (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) + dbg) | Pmodbint bi -> box_int bi (safe_divmod Cmodi - (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)) + (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) + dbg) | Pandbint bi -> box_int bi (Cop(Cand, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) @@ -1272,7 +1279,7 @@ and transl_prim_2 p arg1 arg2 = | _ -> fatal_error "Cmmgen.transl_prim_2" -and transl_prim_3 p arg1 arg2 arg3 = +and transl_prim_3 p arg1 arg2 arg3 dbg = match p with (* String operations *) Pstringsetu -> @@ -1284,7 +1291,7 @@ and transl_prim_3 p arg1 arg2 arg3 = (bind "str" (transl arg1) (fun str -> bind "index" (untag_int (transl arg2)) (fun idx -> Csequence( - Cop(Ccheckbound, [string_length str; idx]), + Cop(Ccheckbound dbg, [string_length str; idx]), Cop(Cstore Byte_unsigned, [add_int str idx; untag_int(transl arg3)]))))) @@ -1313,25 +1320,25 @@ and transl_prim_3 p arg1 arg2 arg3 = bind "arr" (transl arg1) (fun arr -> bind "header" (header arr) (fun hdr -> Cifthenelse(is_addr_array_hdr hdr, - Csequence(Cop(Ccheckbound, [addr_array_length hdr; idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]), addr_array_set arr idx newval), - Csequence(Cop(Ccheckbound, [float_array_length hdr; idx]), + Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]), float_array_set arr idx (unbox_float newval))))))) | Paddrarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, [addr_array_length(header arr); idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]), addr_array_set arr idx (transl arg3)))) | Pintarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, [addr_array_length(header arr); idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]), int_array_set arr idx (transl arg3)))) | Pfloatarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, [float_array_length(header arr);idx]), + Csequence(Cop(Ccheckbound dbg, [float_array_length(header arr);idx]), float_array_set arr idx (transl_unbox_float arg3)))) end) | _ -> @@ -1348,7 +1355,7 @@ and transl_unbox_int bi = function Cconst_natint n | Uconst(Const_base(Const_int64 n)) -> assert (size_int = 8); Cconst_natint (Int64.to_nativeint n) - | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))]) when bi = bi' -> + | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))], _) when bi = bi' -> Cconst_int i | exp -> unbox_int bi (transl exp) @@ -1382,9 +1389,9 @@ and exit_if_true cond nfail otherwise = match cond with | Uconst (Const_pointer 0) -> otherwise | Uconst (Const_pointer 1) -> Cexit (nfail,[]) - | Uprim(Psequor, [arg1; arg2]) -> + | Uprim(Psequor, [arg1; arg2], _) -> exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) - | Uprim(Psequand, _) -> + | Uprim(Psequand, _, _) -> begin match otherwise with | Cexit (raise_num,[]) -> exit_if_false cond (Cexit (nfail,[])) raise_num @@ -1395,7 +1402,7 @@ and exit_if_true cond nfail otherwise = (exit_if_false cond (Cexit (nfail,[])) raise_num) otherwise end - | Uprim(Pnot, [arg]) -> + | Uprim(Pnot, [arg], _) -> exit_if_false arg otherwise nfail | Uifthenelse (cond, ifso, ifnot) -> make_catch2 @@ -1412,9 +1419,9 @@ and exit_if_false cond otherwise nfail = match cond with | Uconst (Const_pointer 0) -> Cexit (nfail,[]) | Uconst (Const_pointer 1) -> otherwise - | Uprim(Psequand, [arg1; arg2]) -> + | Uprim(Psequand, [arg1; arg2], _) -> exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail - | Uprim(Psequor, _ ) -> + | Uprim(Psequor, _, _) -> begin match otherwise with | Cexit (raise_num,[]) -> exit_if_true cond raise_num (Cexit (nfail,[])) @@ -1425,7 +1432,7 @@ and exit_if_false cond otherwise nfail = (exit_if_true cond raise_num (Cexit (nfail,[]))) otherwise end - | Uprim(Pnot, [arg]) -> + | Uprim(Pnot, [arg], _) -> exit_if_true arg nfail otherwise | Uifthenelse (cond, ifso, ifnot) -> make_catch2 @@ -1474,7 +1481,7 @@ and transl_letrec bindings cont = let rec init_blocks = function | [] -> fill_nonrec bsz | (id, exp, RHS_block sz) :: rem -> - Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true), + Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true, Debuginfo.none), [int_const sz]), init_blocks rem) | (id, exp, RHS_nonrec) :: rem -> @@ -1487,7 +1494,7 @@ and transl_letrec bindings cont = and fill_blocks = function | [] -> cont | (id, exp, RHS_block _) :: rem -> - Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false), + Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), [Cvar id; transl exp]), fill_blocks rem) | (id, exp, RHS_nonrec) :: rem -> @@ -1774,12 +1781,12 @@ let apply_function_body arity = let clos = Ident.create "clos" in let rec app_fun clos n = if n = arity-1 then - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]) else begin let newclos = Ident.create "clos" in Clet(newclos, - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]), app_fun newclos (n+1)) end in @@ -1789,7 +1796,7 @@ let apply_function_body arity = if arity = 1 then app_fun clos 0 else Cifthenelse( Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]), - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args), app_fun clos 0)) @@ -1854,7 +1861,7 @@ let tuplify_function arity = {fun_name = "caml_tuplify" ^ string_of_int arity; fun_args = [arg, typ_addr; clos, typ_addr]; fun_body = - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]); fun_fast = true} @@ -1878,7 +1885,7 @@ let final_curry_function arity = let last_clos = Ident.create "clos" in let rec curry_fun args clos n = if n = 0 then - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: args @ [Cvar last_arg; Cvar clos]) else begin @@ -1929,7 +1936,8 @@ let entry_point namelist = List.fold_right (fun name next -> let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in - Csequence(Cop(Capply typ_void, [Cconst_symbol entry_sym]), + Csequence(Cop(Capply(typ_void, Debuginfo.none), + [Cconst_symbol entry_sym]), Csequence(incr_global_inited, next))) namelist (Cconst_int 1) in Cfunction {fun_name = "caml_program"; diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index adc4123aa..5a862b172 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -49,13 +49,14 @@ let rec combine i allocstate = (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs) end end - | Iop(Icall_ind | Icall_imm _ | Iextcall(_, _) | + | Iop(Icall_ind | Icall_imm _ | Iextcall _ | Itailcall_ind | Itailcall_imm _) -> let newnext = combine_restart i.next in - (instr_cons i.desc i.arg i.res newnext, allocated_size allocstate) + (instr_cons_debug i.desc i.arg i.res i.dbg newnext, + allocated_size allocstate) | Iop op -> let (newnext, sz) = combine i.next allocstate in - (instr_cons i.desc i.arg i.res newnext, sz) + (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz) | Iifthenelse(test, ifso, ifnot) -> let newifso = combine_restart ifso in let newifnot = combine_restart ifnot in diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml new file mode 100644 index 000000000..84390442b --- /dev/null +++ b/asmcomp/debuginfo.ml @@ -0,0 +1,52 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Lexing +open Location + +type kind = Dinfo_call | Dinfo_raise + +type t = { + dinfo_kind: kind; + dinfo_file: string; + dinfo_line: int; + dinfo_char_start: int; + dinfo_char_end: int +} + +let none = { + dinfo_kind = Dinfo_call; + dinfo_file = ""; + dinfo_line = 0; + dinfo_char_start = 0; + dinfo_char_end = 0 +} + +let to_string d = + if d == none + then "" + else Printf.sprintf "{%s:%d,%d-%d}" + d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end + +let from_location kind loc = + if loc.loc_ghost then none else + { dinfo_kind = kind; + dinfo_file = loc.loc_start.pos_fname; + dinfo_line = loc.loc_start.pos_lnum; + dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; + dinfo_char_end = + if loc.loc_end.pos_fname = loc.loc_start.pos_fname + then loc.loc_end.pos_cnum - loc.loc_start.pos_bol + else loc.loc_start.pos_cnum - loc.loc_start.pos_bol } + +let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc +let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli new file mode 100644 index 000000000..151cd0abb --- /dev/null +++ b/asmcomp/debuginfo.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +type kind = Dinfo_call | Dinfo_raise + +type t = { + dinfo_kind: kind; + dinfo_file: string; + dinfo_line: int; + dinfo_char_start: int; + dinfo_char_end: int +} + +val none: t + +val to_string: t -> string + +val from_location: kind -> Location.t -> t + +val from_call: Lambda.lambda_event -> t +val from_raise: Lambda.lambda_event -> t + diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index fa94c9768..d1964d356 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -14,6 +14,11 @@ (* Common functions for emitting assembly code *) +open Debuginfo +open Cmm +open Reg +open Linearize + let output_channel = ref stdout let emit_string s = output_string !output_channel s @@ -27,6 +32,8 @@ let emit_nativeint n = output_string !output_channel (Nativeint.to_string n) let emit_printf fmt = Printf.fprintf !output_channel fmt +let emit_int32 n = emit_printf "0x%lx" n + let emit_symbol esc s = for i = 0 to String.length s - 1 do let c = s.[i] in @@ -86,3 +93,66 @@ let emit_bytes_directive directive s = done; if !pos > 0 then emit_char '\n' +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list; (* Offsets/regs of live addresses *) + fd_debuginfo: Debuginfo.t } (* Location, if any *) + +let frame_descriptors = ref([] : frame_descr list) + +type emit_frame_actions = + { efa_label: int -> unit; + efa_16: int -> unit; + efa_32: int32 -> unit; + efa_word: int -> unit; + efa_align: int -> unit; + efa_label_rel: int -> int32 -> unit; + efa_def_label: int -> unit; + efa_string: string -> unit } + +let emit_frames a = + let filenames = Hashtbl.create 7 in + let lbl_filenames = ref 200000 in + let label_filename name = + try + Hashtbl.find filenames name + with Not_found -> + let lbl = !lbl_filenames in + Hashtbl.add filenames name lbl; + incr lbl_filenames; + lbl in + let emit_frame fd = + a.efa_label fd.fd_lbl; + a.efa_16 (if fd.fd_debuginfo == Debuginfo.none + then fd.fd_frame_size + else fd.fd_frame_size + 1); + a.efa_16 (List.length fd.fd_live_offset); + List.iter a.efa_16 fd.fd_live_offset; + a.efa_align Arch.size_addr; + if fd.fd_debuginfo != Debuginfo.none then begin + let d = fd.fd_debuginfo in + let line = min 0xFFFFF d.dinfo_line + and char_start = min 0xFF d.dinfo_char_start + and char_end = min 0x3FF d.dinfo_char_end + and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in + let info = + Int64.add (Int64.shift_left (Int64.of_int line) 44) ( + Int64.add (Int64.shift_left (Int64.of_int char_start) 36) ( + Int64.add (Int64.shift_left (Int64.of_int char_end) 26) + (Int64.of_int kind))) in + a.efa_label_rel + (label_filename d.dinfo_file) + (Int64.to_int32 info); + a.efa_32 (Int64.to_int32 (Int64.shift_right info 32)) + end in + let emit_filename name lbl = + a.efa_def_label lbl; + a.efa_string name; + a.efa_align Arch.size_addr in + a.efa_word (List.length !frame_descriptors); + List.iter emit_frame !frame_descriptors; + Hashtbl.iter emit_filename filenames; + frame_descriptors := [] diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index 0ec5ee6c9..38e6df960 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -18,9 +18,30 @@ val output_channel: out_channel ref val emit_string: string -> unit val emit_int: int -> unit val emit_nativeint: nativeint -> unit +val emit_int32: int32 -> unit val emit_symbol: char -> string -> unit val emit_printf: ('a, out_channel, unit) format -> 'a val emit_char: char -> unit val emit_string_literal: string -> unit val emit_string_directive: string -> string -> unit val emit_bytes_directive: string -> string -> unit + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list; (* Offsets/regs of live addresses *) + fd_debuginfo: Debuginfo.t } (* Location, if any *) + +val frame_descriptors : frame_descr list ref + +type emit_frame_actions = + { efa_label: int -> unit; + efa_16: int -> unit; + efa_32: int32 -> unit; + efa_word: int -> unit; + efa_align: int -> unit; + efa_label_rel: int -> int32 -> unit; + efa_def_label: int -> unit; + efa_string: string -> unit } + +val emit_frames: emit_frame_actions -> unit diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 7e3b23290..b8191771a 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -175,14 +175,7 @@ let emit_addressing addr r n = (* Record live pointers at call points *) -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = +let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter @@ -196,21 +189,12 @@ let record_frame_label live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:\n` - -let emit_frame fd = - ` .long {emit_label fd.fd_lbl}\n`; - ` {emit_string word_dir} {emit_int fd.fd_frame_size}\n`; - ` {emit_string word_dir} {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` {emit_string word_dir} {emit_int n}\n`) - fd.fd_live_offset; - emit_align 4 +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) @@ -225,6 +209,38 @@ let emit_call_gc gc = `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` +(* Record calls to caml_ml_array_bound_error. + In -g mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Without -g, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: call {emit_symbol "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then + `{emit_label !bound_error_call}: jmp {emit_symbol "caml_ml_array_bound_error"}\n` + (* Names for instructions *) let instr_for_intop = function @@ -442,10 +458,10 @@ let emit_instr fallthrough i = ` movl ${emit_symbol s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> ` call *{emit_reg i.arg.(0)}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Icall_imm s) -> ` call {emit_symbol s}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); ` jmp *{emit_reg i.arg.(0)}\n` @@ -466,7 +482,7 @@ let emit_instr fallthrough i = ` movl L{emit_symbol s}$non_lazy_ptr, %eax\n` end; ` call {emit_symbol "caml_c_call"}\n`; - record_frame i.live + record_frame i.live i.dbg end else begin if not macosx then ` call {emit_symbol s}\n` @@ -530,7 +546,7 @@ let emit_instr fallthrough i = ` movl %eax, {emit_symbol "caml_young_ptr"}\n`; ` cmpl {emit_symbol "caml_young_limit"}, %eax\n`; let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live in + let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` leal 4(%eax), {emit_reg i.res.(0)}\n`; call_gc_sites := @@ -545,7 +561,7 @@ let emit_instr fallthrough i = | _ -> ` movl ${emit_int n}, %eax\n`; ` call {emit_symbol "caml_allocN"}\n` end; - `{record_frame i.live} leal 4(%eax), {emit_reg i.res.(0)}\n` + `{record_frame i.live Debuginfo.none} leal 4(%eax), {emit_reg i.res.(0)}\n` end | Lop(Iintop(Icomp cmp)) -> ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; @@ -558,13 +574,13 @@ let emit_instr fallthrough i = ` set{emit_string b} %al\n`; ` movzbl %al, {emit_reg i.res.(0)}\n` | Lop(Iintop Icheckbound) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cltd\n`; ` idivl {emit_reg i.arg.(1)}\n` @@ -775,14 +791,18 @@ let emit_instr fallthrough i = ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; stack_offset := !stack_offset - trap_frame_size | Lraise -> - ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; - ` popl {emit_symbol "caml_exception_pointer"}\n`; - if trap_frame_size > 8 then - ` addl ${emit_int (trap_frame_size - 8)}, %esp\n`; - ` ret\n` + if !Clflags.debug then begin + ` call {emit_symbol "caml_raise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; + ` popl {emit_symbol "caml_exception_pointer"}\n`; + if trap_frame_size > 8 then + ` addl ${emit_int (trap_frame_size - 8)}, %esp\n`; + ` ret\n` + end let rec emit_all fallthrough i = - match i.desc with | Lend -> () | _ -> @@ -873,7 +893,8 @@ let fundecl fundecl = stack_offset := 0; float_constants := []; call_gc_sites := []; - range_check_trap := 0; + bound_error_sites := []; + bound_error_call := 0; ` .text\n`; emit_align 16; declare_function_symbol fundecl.fun_name; @@ -885,9 +906,7 @@ let fundecl fundecl = `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; - if !range_check_trap > 0 then - `{emit_label !range_check_trap}: call {emit_symbol "caml_ml_array_bound_error"}\n`; - (* Never returns, but useful to have retaddr on stack for debugging *) + emit_call_bound_errors (); List.iter emit_float_constant !float_constants (* Emission of data *) @@ -953,7 +972,18 @@ let end_assembly() = let lbl = Compilenv.make_symbol (Some "frametable") in ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; - ` .long {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := []; + emit_frames + { efa_label = (fun l -> ` .long {emit_label l}\n`); + efa_16 = (fun n -> ` {emit_string word_dir} {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .long {emit_int n}\n`); + efa_align = emit_align; + efa_label_rel = (fun lbl ofs -> + ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l}:\n`); + efa_string = (fun s -> + let s = s ^ "\000" in + if use_ascii_dir + then emit_string_directive " .ascii " s + else emit_bytes_directive " .byte " s) }; if macosx then emit_external_symbols () diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index 45aa6aa92..bba42fe88 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -64,6 +64,8 @@ let add_used_symbol s = let emit_symbol s = emit_string "_"; Emitaux.emit_symbol '$' s +let emit_int32 n = emit_printf "0%lxh" n + (* Output a label *) let emit_label lbl = @@ -140,14 +142,7 @@ let emit_addressing addr r n = (* Record live pointers at call points *) -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = +let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter @@ -161,21 +156,12 @@ let record_frame_label live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:\n` - -let emit_frame fd = - ` DWORD {emit_label fd.fd_lbl}\n`; - ` WORD {emit_int fd.fd_frame_size}\n`; - ` WORD {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` WORD {emit_int n}\n`) - fd.fd_live_offset; - emit_align 4 +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) @@ -190,6 +176,38 @@ let emit_call_gc gc = `{emit_label gc.gc_lbl}: call _caml_call_gc\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` +(* Record calls to caml_ml_array_bound_error. + In -g mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Without -g, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: call _caml_ml_array_bound_error\n`; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then + `{emit_label !bound_error_call}: jmp _caml_ml_array_bound_error\n` + (* Names for instructions *) let instr_for_intop = function @@ -396,11 +414,11 @@ let emit_instr i = ` mov {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n` | Lop(Icall_ind) -> ` call {emit_reg i.arg.(0)}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Icall_imm s) -> add_used_symbol s; ` call {emit_symbol s}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); ` jmp {emit_reg i.arg.(0)}\n` @@ -417,7 +435,7 @@ let emit_instr i = if alloc then begin ` mov eax, OFFSET {emit_symbol s}\n`; ` call _caml_c_call\n`; - record_frame i.live + record_frame i.live i.dbg end else begin ` call {emit_symbol s}\n` end @@ -475,7 +493,7 @@ let emit_instr i = ` mov _caml_young_ptr, eax\n`; ` cmp eax, _caml_young_limit\n`; let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live in + let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` lea {emit_reg i.res.(0)}, [eax+4]\n`; call_gc_sites := @@ -490,7 +508,7 @@ let emit_instr i = | _ -> ` mov eax, {emit_int n}\n`; ` call _caml_allocN\n` end; - `{record_frame i.live} lea {emit_reg i.res.(0)}, [eax+4]\n` + `{record_frame i.live Debuginfo.none} lea {emit_reg i.res.(0)}, [eax+4]\n` end | Lop(Iintop(Icomp cmp)) -> ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; @@ -503,13 +521,13 @@ let emit_instr i = ` set{emit_string b} al\n`; ` movzx {emit_reg i.res.(0)}, al\n` | Lop(Iintop Icheckbound) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cdq\n`; ` idiv {emit_reg i.arg.(1)}\n` @@ -721,9 +739,14 @@ let emit_instr i = ` add esp, 4\n`; stack_offset := !stack_offset - 8 | Lraise -> - ` mov esp, _caml_exception_pointer\n`; - ` pop _caml_exception_pointer\n`; - ` ret\n` + if !Clflags.debug then begin + ` call _caml_raise_exn\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` mov esp, _caml_exception_pointer\n`; + ` pop _caml_exception_pointer\n`; + ` ret\n` + end let rec emit_all i = match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next @@ -759,7 +782,8 @@ let fundecl fundecl = stack_offset := 0; float_constants := []; call_gc_sites := []; - range_check_trap := 0; + bound_error_sites := []; + bound_error_call := 0; ` .CODE\n`; add_def_symbol fundecl.fun_name; emit_align 4; @@ -771,8 +795,7 @@ let fundecl fundecl = `{emit_label !tailrec_entry_point}:\n`; emit_all fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; - if !range_check_trap > 0 then - `{emit_label !range_check_trap}: jmp _caml_ml_array_bound_error\n`; + emit_call_bound_errors (); begin match !float_constants with [] -> () | _ -> @@ -835,6 +858,7 @@ let begin_assembly() = ` EXTERN _caml_alloc2: PROC\n`; ` EXTERN _caml_alloc3: PROC\n`; ` EXTERN _caml_ml_array_bound_error: PROC\n`; + ` EXTERN _caml_raise_exn: PROC\n`; ` .DATA\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in add_def_symbol lbl_begin; @@ -860,9 +884,17 @@ let end_assembly() = let lbl = Compilenv.make_symbol (Some "frametable") in add_def_symbol lbl; ` PUBLIC {emit_symbol lbl}\n`; - `{emit_symbol lbl} DWORD {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := []; + `{emit_symbol lbl}`; + emit_frames + { efa_label = (fun l -> ` DWORD {emit_label l}\n`); + efa_16 = (fun n -> ` WORD {emit_int n}\n`); + efa_32 = (fun n -> ` DWORD {emit_int32 n}\n`); + efa_word = (fun n -> ` DWORD {emit_int n}\n`); + efa_align = emit_align; + efa_label_rel = (fun lbl ofs -> + ` DWORD {emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l} LABEL DWORD\n`); + efa_string = (fun s -> emit_bytes_directive " BYTE " (s ^ "\000")) }; `\n;External functions\n\n`; StringSet.iter (fun s -> diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index 85cd18e1e..2f0dd90ee 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -88,7 +88,7 @@ let rec float_needs = function let n1 = float_needs arg1 in let n2 = float_needs arg2 in if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2 - | Cop(Cextcall(fn, ty_res, alloc), args) + | Cop(Cextcall(fn, ty_res, alloc, dbg), args) when !fast_math && List.mem fn inline_float_ops -> begin match args with [arg] -> float_needs arg @@ -161,7 +161,7 @@ method is_immediate (n : int) = true method is_simple_expr e = match e with - | Cop(Cextcall(fn, _, alloc), args) + | Cop(Cextcall(fn, _, alloc, _), args) when !fast_math && List.mem fn inline_float_ops -> (* inlined float ops are simple if their arguments are *) List.for_all self#is_simple_expr args @@ -239,7 +239,7 @@ method select_operation op args = super#select_operation op args end (* Recognize inlined floating point operations *) - | Cextcall(fn, ty_res, false) + | Cextcall(fn, ty_res, false, dbg) when !fast_math && List.mem fn inline_float_ops -> (Ispecific(Ifloatspecial fn), args) (* Default *) @@ -269,18 +269,21 @@ method select_floatarith regular_op reversed_op mem_op mem_rev_op args = (* Deal with register constraints *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = try let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in self#insert_moves rs rsrc; - self#insert (Iop op) rsrc rdst; + self#insert_debug (Iop op) dbg rsrc rdst; if move_res then begin self#insert_moves rdst rd; rd end else rdst with Use_default -> - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd + +method insert_op op rs rd = + self#insert_op_debug op Debuginfo.none rs rd (* Selection of push instructions for external calls *) diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 506f5a11c..47e4dc68a 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -28,6 +28,7 @@ type instruction = mutable next: instruction; arg: Reg.t array; res: Reg.t array; + dbg: Debuginfo.t; live: Reg.Set.t } and instruction_desc = @@ -77,24 +78,28 @@ let rec end_instr = next = end_instr; arg = [||]; res = [||]; + dbg = Debuginfo.none; live = Reg.Set.empty } -(* Cons an instruction (live empty) *) +(* Cons an instruction (live, debug empty) *) let instr_cons d a r n = - { desc = d; next = n; arg = a; res = r; live = Reg.Set.empty } + { desc = d; next = n; arg = a; res = r; + dbg = Debuginfo.none; live = Reg.Set.empty } (* Cons a simple instruction (arg, res, live empty) *) let cons_instr d n = - { desc = d; next = n; arg = [||]; res = [||]; live = Reg.Set.empty } + { desc = d; next = n; arg = [||]; res = [||]; + dbg = Debuginfo.none; live = Reg.Set.empty } -(* Build an instruction with arg, res, live taken from +(* Build an instruction with arg, res, dbg, live taken from the given Mach.instruction *) let copy_instr d i n = { desc = d; next = n; - arg = i.Mach.arg; res = i.Mach.res; live = i.Mach.live } + arg = i.Mach.arg; res = i.Mach.res; + dbg = i.Mach.dbg; live = i.Mach.live } (* Label the beginning of the given instruction sequence. diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index 7a76f07e8..59985acad 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -22,6 +22,7 @@ type instruction = mutable next: instruction; arg: Reg.t array; res: Reg.t array; + dbg: Debuginfo.t; live: Reg.Set.t } and instruction_desc = diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index c9c90c8b5..4e743d646 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -98,7 +98,7 @@ let rec live i finally = let across_after = Reg.diff_set_array (live i.next finally) i.res in let across = match i.desc with - Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall(_, _)) + Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> (* The function call may raise an exception, branching to the nearest enclosing try ... with. Similarly for bounds checks. diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 6417b5c40..13c831fc1 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -60,6 +60,7 @@ type instruction = next: instruction; arg: Reg.t array; res: Reg.t array; + dbg: Debuginfo.t; mutable live: Reg.Set.t } and instruction_desc = @@ -85,6 +86,7 @@ let rec dummy_instr = next = dummy_instr; arg = [||]; res = [||]; + dbg = Debuginfo.none; live = Reg.Set.empty } let end_instr () = @@ -92,13 +94,15 @@ let end_instr () = next = dummy_instr; arg = [||]; res = [||]; + dbg = Debuginfo.none; live = Reg.Set.empty } let instr_cons d a r n = - { desc = d; next = n; arg = a; res = r; live = Reg.Set.empty } + { desc = d; next = n; arg = a; res = r; + dbg = Debuginfo.none; live = Reg.Set.empty } -let instr_cons_live d a r l n = - { desc = d; next = n; arg = a; res = r; live = l } +let instr_cons_debug d a r dbg n = + { desc = d; next = n; arg = a; res = r; dbg = dbg; live = Reg.Set.empty } let rec instr_iter f i = match i.desc with diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index ec10ffb81..f1b5eae8b 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -60,6 +60,7 @@ type instruction = next: instruction; arg: Reg.t array; res: Reg.t array; + dbg: Debuginfo.t; mutable live: Reg.Set.t } and instruction_desc = @@ -85,8 +86,8 @@ val end_instr: unit -> instruction val instr_cons: instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction -val instr_cons_live: - instruction_desc -> Reg.t array -> Reg.t array -> Reg.Set.t -> +val instr_cons_debug: + instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t -> instruction -> instruction val instr_iter: (instruction -> unit) -> instruction -> unit diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index 274e111a3..46702e37e 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -47,6 +47,13 @@ let slot_offset loc cls = | Incoming n -> frame_size() + n | Outgoing n -> n +(* Whether stack backtraces are supported *) + +let supports_backtraces = + match Config.system with + | "rhapsody" -> true + | _ -> false + (* Output a symbol *) let emit_symbol = @@ -208,14 +215,7 @@ let emit_set_comp cmp res = (* Record live pointers at call points *) -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame live = +let record_frame live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter @@ -229,18 +229,9 @@ let record_frame live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - `{emit_label lbl}:` - -let emit_frame fd = - ` {emit_string datag} {emit_label fd.fd_lbl} + 4\n`; - ` .short {emit_int fd.fd_frame_size}\n`; - ` .short {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .short {emit_int n}\n`) - fd.fd_live_offset; - ` .align {emit_int aligng}\n` + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; + `{emit_label lbl}:\n` (* Record floating-point and large integer literals *) @@ -497,11 +488,11 @@ let rec emit_instr i dslot = ` addi {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_lower emit_symbol s}\n` | Lop(Icall_ind) -> ` mtctr {emit_reg i.arg.(0)}\n`; - record_frame i.live; - ` bctrl\n` + ` bctrl\n`; + record_frame i.live i.dbg | Lop(Icall_imm s) -> - record_frame i.live; - ` bl {emit_symbol s}\n` + ` bl {emit_symbol s}\n`; + record_frame i.live i.dbg | Lop(Itailcall_ind) -> let n = frame_size() in ` mtctr {emit_reg i.arg.(0)}\n`; @@ -539,8 +530,8 @@ let rec emit_instr i dslot = ` addis {emit_gpr 11}, 0, {emit_upper emit_symbol s}\n`; ` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_symbol s}\n` end; - record_frame i.live; - ` bl {emit_symbol "caml_c_call"}\n` + ` bl {emit_symbol "caml_c_call"}\n`; + record_frame i.live i.dbg end else begin if pic_externals then begin external_functions := StringSet.add s !external_functions; @@ -584,16 +575,16 @@ let rec emit_instr i dslot = ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; ` {emit_string cmplg} {emit_gpr 31}, {emit_gpr 30}\n`; ` addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n`; - record_frame i.live; - ` bltl {emit_label !call_gc_label}\n` + ` bltl {emit_label !call_gc_label}\n`; + record_frame i.live Debuginfo.none | Lop(Ispecific(Ialloc_far n)) -> if !call_gc_label = 0 then call_gc_label := new_label(); let lbl = new_label() in ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; ` {emit_string cmplg} {emit_gpr 31}, {emit_gpr 30}\n`; ` bge {emit_label lbl}\n`; - record_frame i.live; ` bl {emit_label !call_gc_label}\n`; + record_frame i.live Debuginfo.none; `{emit_label lbl}: addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n` | Lop(Iintop Isub) -> (* subfc has swapped arguments *) ` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` @@ -611,6 +602,8 @@ let rec emit_instr i dslot = emit_set_comp c i.res.(0) end | Lop(Iintop Icheckbound) -> + if !Clflags.debug && supports_backtraces then + record_frame Reg.Set.empty i.dbg; ` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> let instr = name_for_intop op in @@ -637,6 +630,8 @@ let rec emit_instr i dslot = emit_set_comp c i.res.(0) end | Lop(Iintop_imm(Icheckbound, n)) -> + if !Clflags.debug && supports_backtraces then + record_frame Reg.Set.empty i.dbg; ` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_intop_imm op in @@ -777,12 +772,17 @@ let rec emit_instr i dslot = ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; stack_offset := !stack_offset - 16 | Lraise -> - ` {emit_string lg} {emit_gpr 0}, 0({emit_gpr 29})\n`; - ` mr {emit_gpr 1}, {emit_gpr 29}\n`; - ` mtlr {emit_gpr 0}\n`; - ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; - ` blr\n` + if !Clflags.debug && supports_backtraces then begin + ` bl {emit_symbol "caml_raise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` {emit_string lg} {emit_gpr 0}, 0({emit_gpr 29})\n`; + ` mr {emit_gpr 1}, {emit_gpr 29}\n`; + ` mtlr {emit_gpr 0}\n`; + ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; + ` blr\n` + end and emit_delay = function None -> () @@ -968,6 +968,14 @@ let end_assembly() = let lbl = Compilenv.make_symbol (Some "frametable") in declare_global_data lbl; `{emit_symbol lbl}:\n`; - ` {emit_string datag} {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] + emit_frames + { efa_label = (fun l -> ` {emit_string datag} {emit_label l}\n`); + efa_16 = (fun n -> ` .short {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` {emit_string datag} {emit_int n}\n`); + efa_align = (fun n -> ` .align {emit_int (Misc.log2 n)}\n`); + efa_label_rel = (fun lbl ofs -> + ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l}:\n`); + efa_string = (fun s -> emit_bytes_directive " .byte " (s ^ "\000")) + } diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index e90dbccb4..0d592ac03 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -51,8 +51,9 @@ let chunk = function | Double_u -> "float64u" let operation = function - | Capply ty -> "app" - | Cextcall(lbl, ty, alloc) -> Printf.sprintf "extcall \"%s\"" lbl + | Capply(ty, d) -> "app" ^ Debuginfo.to_string d + | Cextcall(lbl, ty, alloc, d) -> + Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d) | Cload Word -> "load" | Cload c -> Printf.sprintf "load %s" (chunk c) | Calloc -> "alloc" @@ -82,8 +83,8 @@ let operation = function | Cfloatofint -> "floatofint" | Cintoffloat -> "intoffloat" | Ccmpf c -> Printf.sprintf "%sf" (comparison c) - | Craise -> "raise" - | Ccheckbound -> "checkbound" + | Craise d -> "raise" ^ Debuginfo.to_string d + | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n @@ -123,8 +124,8 @@ let rec expr ppf = function fprintf ppf "@[<2>(%s" (operation op); List.iter (fun e -> fprintf ppf "@ %a" expr e) el; begin match op with - | Capply mty -> fprintf ppf "@ %a" machtype mty - | Cextcall(_, mty, _) -> fprintf ppf "@ %a" machtype mty + | Capply (mty, _) -> fprintf ppf "@ %a" machtype mty + | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty | _ -> () end; fprintf ppf ")@]" diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index cf2baa078..3737e72c1 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -23,7 +23,7 @@ let label ppf l = Format.fprintf ppf "L%i" l let instr ppf i = - match i.desc with + begin match i.desc with | Lend -> () | Lop op -> begin match op with @@ -64,6 +64,9 @@ let instr ppf i = fprintf ppf "pop trap" | Lraise -> fprintf ppf "raise %a" reg i.arg.(0) + end; + if i.dbg != Debuginfo.none then + fprintf ppf " %s" (Debuginfo.to_string i.dbg) let rec all_instr ppf i = match i.desc with diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 17cf675b9..bd1006a93 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -42,7 +42,7 @@ let regs ppf v = | 0 -> () | 1 -> reg ppf v.(0) | n -> reg ppf v.(0); - for i = 1 to n-1 do fprintf ppf "@ %a" reg v.(i) done + for i = 1 to n-1 do fprintf ppf " %a" reg v.(i) done let regset ppf s = let first = ref true in @@ -182,6 +182,8 @@ let rec instr ppf i = | Iraise -> fprintf ppf "raise %a" reg i.arg.(0) end; + if i.dbg != Debuginfo.none then + fprintf ppf " %s" (Debuginfo.to_string i.dbg); begin match i.next.desc with Iend -> () | _ -> fprintf ppf "@,%a" instr i.next diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index f4b3cf7ff..c8e9f4919 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -94,19 +94,19 @@ method private reload i = | Iop(Itailcall_ind) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg - (instr_cons_live i.desc newarg i.res i.live i.next) - | Iop(Icall_imm _ | Iextcall(_, _)) -> - instr_cons_live i.desc i.arg i.res i.live (self#reload i.next) + {i with arg = newarg} + | Iop(Icall_imm _ | Iextcall _) -> + {i with next = self#reload i.next} | Iop(Icall_ind) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg - (instr_cons_live i.desc newarg i.res i.live (self#reload i.next)) + {i with arg = newarg; next = self#reload i.next} | Iop op -> let (newarg, newres) = self#reload_operation op i.arg i.res in insert_moves i.arg newarg - (instr_cons_live i.desc newarg newres i.live + {i with arg = newarg; res = newres; next = (insert_moves newres i.res - (self#reload i.next))) + (self#reload i.next))} | Iifthenelse(tst, ifso, ifnot) -> let newarg = self#reload_test tst i.arg in insert_moves i.arg newarg diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index 681d36d50..fae061b19 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -123,7 +123,7 @@ method oper_in_basic_block = function | Icall_imm _ -> false | Itailcall_ind -> false | Itailcall_imm _ -> false - | Iextcall(_, _) -> false + | Iextcall _ -> false | Istackoffset _ -> false | Ialloc _ -> false | _ -> true @@ -328,8 +328,7 @@ method schedule_fundecl f = clear_code_dag(); schedule_block [] i end else - { desc = i.desc; arg = i.arg; res = i.res; live = i.live; - next = schedule i.next } + { i with next = schedule i.next } and schedule_block ready_queue i = if self#instr_in_basic_block i then @@ -338,7 +337,7 @@ method schedule_fundecl f = let critical_outputs = match i.desc with Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |] - | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall(_, _)) -> [||] + | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall _) -> [||] | Lreturn -> [||] | _ -> i.arg in List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue; diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 7cb2c387d..6089b5ad6 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -25,8 +25,8 @@ type environment = (Ident.t, Reg.t array) Tbl.t (* Infer the type of the result of an operation *) let oper_result_type = function - Capply ty -> ty - | Cextcall(s, ty, alloc) -> ty + Capply(ty, _) -> ty + | Cextcall(s, ty, alloc, _) -> ty | Cload c -> begin match c with Word -> typ_addr @@ -42,8 +42,8 @@ let oper_result_type = function | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf -> typ_float | Cfloatofint -> typ_float | Cintoffloat -> typ_int - | Craise -> typ_void - | Ccheckbound -> typ_void + | Craise _ -> typ_void + | Ccheckbound _ -> typ_void (* Infer the size in bytes of the result of a simple expression *) @@ -151,6 +151,14 @@ let join_array rs = done; Some res +(* Extract debug info contained in a C-- operation *) +let debuginfo_op = function + | Capply(_, dbg) -> dbg + | Cextcall(_, _, _, dbg) -> dbg + | Craise dbg -> dbg + | Ccheckbound dbg -> dbg + | _ -> Debuginfo.none + (* Registers for catch constructs *) let catch_regs = ref [] @@ -182,7 +190,7 @@ method is_simple_expr = function | Cop(op, args) -> begin match op with (* The following may have side effects *) - | Capply _ | Cextcall(_, _, _) | Calloc | Cstore _ | Craise -> false + | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ -> false (* The remaining operations are simple if their args are *) | _ -> List.for_all self#is_simple_expr args @@ -207,9 +215,9 @@ method select_store addr arg = method select_operation op args = match (op, args) with - (Capply ty, Cconst_symbol s :: rem) -> (Icall_imm s, rem) - | (Capply ty, _) -> (Icall_ind, args) - | (Cextcall(s, ty, alloc), _) -> (Iextcall(s, alloc), args) + (Capply(ty, dbg), Cconst_symbol s :: rem) -> (Icall_imm s, rem) + | (Capply(ty, dbg), _) -> (Icall_ind, args) + | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args) | (Cload chunk, [arg]) -> let (addr, eloc) = self#select_addressing arg in (Iload(chunk, addr), [eloc]) @@ -256,7 +264,7 @@ method select_operation op args = | (Cdivf, _) -> (Idivf, args) | (Cfloatofint, _) -> (Ifloatofint, args) | (Cintoffloat, _) -> (Iintoffloat, args) - | (Ccheckbound, _) -> self#select_arith Icheckbound args + | (Ccheckbound _, _) -> self#select_arith Icheckbound args | _ -> fatal_error "Selection.select_oper" method private select_arith_comm op = function @@ -331,6 +339,9 @@ method select_condition = function val mutable instr_seq = dummy_instr +method insert_debug desc dbg arg res = + instr_seq <- instr_cons_debug desc arg res dbg instr_seq + method insert desc arg res = instr_seq <- instr_cons desc arg res instr_seq @@ -338,7 +349,7 @@ method extract = let rec extract res i = if i == dummy_instr then res - else extract (instr_cons i.desc i.arg i.res res) i.next in + else extract {i with next = res} i.next in extract (end_instr()) instr_seq (* Insert a sequence of moves from one pseudoreg set to another. *) @@ -366,6 +377,10 @@ method insert_move_results loc res stacksize = to insert moves before and after the operation, i.e. for two-address instructions, or instructions using dedicated registers. *) +method insert_op_debug op dbg rs rd = + self#insert_debug (Iop op) dbg rs rd; + rd + method insert_op op rs rd = self#insert (Iop op) rs rd; rd @@ -422,13 +437,13 @@ method emit_expr env exp = | Some(simple_list, ext_env) -> Some(self#emit_tuple ext_env simple_list) end - | Cop(Craise, [arg]) -> + | Cop(Craise dbg, [arg]) -> begin match self#emit_expr env arg with None -> None | Some r1 -> let rd = [|Proc.loc_exn_bucket|] in self#insert (Iop Imove) r1 rd; - self#insert Iraise rd [||]; + self#insert_debug Iraise dbg rd [||]; None end | Cop(Ccmpf comp, args) -> @@ -439,6 +454,7 @@ method emit_expr env exp = | Some(simple_args, env) -> let ty = oper_result_type op in let (new_op, new_args) = self#select_operation op simple_args in + let dbg = debuginfo_op op in match new_op with Icall_ind -> Proc.contains_calls := true; @@ -448,7 +464,7 @@ method emit_expr env exp = let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; - self#insert (Iop Icall_ind) + self#insert_debug (Iop Icall_ind) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd @@ -459,7 +475,7 @@ method emit_expr env exp = let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; - self#insert (Iop(Icall_imm lbl)) loc_arg loc_res; + self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd | Iextcall(lbl, alloc) -> @@ -468,7 +484,8 @@ method emit_expr env exp = self#emit_extcall_args env new_args in let rd = Reg.createv ty in let loc_res = Proc.loc_external_results rd in - self#insert (Iop(Iextcall(lbl, alloc))) loc_arg loc_res; + self#insert_debug (Iop(Iextcall(lbl, alloc))) dbg + loc_arg loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd | Ialloc _ -> @@ -481,7 +498,7 @@ method emit_expr env exp = | op -> let r1 = self#emit_tuple env new_args in let rd = Reg.createv ty in - Some (self#insert_op op r1 rd) + Some (self#insert_op_debug op dbg r1 rd) end | Csequence(e1, e2) -> begin match self#emit_expr env e1 with @@ -676,7 +693,7 @@ method emit_tail env exp = None -> () | Some r1 -> self#emit_tail (self#bind_let env v r1) e2 end - | Cop(Capply ty as op, args) -> + | Cop(Capply(ty, dbg) as op, args) -> begin match self#emit_parts_list env args with None -> () | Some(simple_args, env) -> @@ -695,7 +712,7 @@ method emit_tail env exp = let rd = Reg.createv ty in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; - self#insert (Iop Icall_ind) + self#insert_debug (Iop Icall_ind) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] @@ -715,7 +732,7 @@ method emit_tail env exp = let rd = Reg.createv ty in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; - self#insert (Iop(Icall_imm lbl)) loc_arg loc_res; + self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 7ec1724c4..ed7d5917e 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -43,6 +43,10 @@ class virtual selector_generic : object Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array (* Can be overriden to deal with 2-address instructions or instructions with hardwired input/output registers *) + method insert_op_debug : + Mach.operation -> Debuginfo.t -> Reg.t array -> Reg.t array -> Reg.t array + (* Can be overriden to deal with 2-address instructions + or instructions with hardwired input/output registers *) method emit_extcall_args : environment -> Cmm.expression list -> Reg.t array * int (* Can be overriden to deal with stack-based calling conventions *) @@ -59,6 +63,8 @@ class virtual selector_generic : object are not always applied to "self", but ideally they should be private. *) method extract : Mach.instruction method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit + method insert_debug : Mach.instruction_desc -> Debuginfo.t -> + Reg.t array -> Reg.t array -> unit method insert_move : Reg.t -> Reg.t -> unit method insert_move_args : Reg.t array -> Reg.t array -> int -> unit method insert_move_results : Reg.t array -> Reg.t array -> int -> unit diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 38c990b3f..255795c71 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -147,7 +147,7 @@ let rec reload i before = (* All regs live across must be spilled *) let (new_next, finally) = reload i.next i.live in (add_reloads (Reg.inter_set_array before i.arg) - (instr_cons i.desc i.arg i.res new_next), + (instr_cons_debug i.desc i.arg i.res i.dbg new_next), finally) | Iop op -> let new_before = @@ -160,7 +160,7 @@ let rec reload i before = Reg.diff_set_array (Reg.diff_set_array new_before i.arg) i.res in let (new_next, finally) = reload i.next after in (add_reloads (Reg.inter_set_array new_before i.arg) - (instr_cons i.desc i.arg i.res new_next), + (instr_cons_debug i.desc i.arg i.res i.dbg new_next), finally) | Iifthenelse(test, ifso, ifnot) -> let at_fork = Reg.diff_set_array before i.arg in @@ -292,12 +292,12 @@ let rec spill i finally = let before1 = Reg.diff_set_array after i.res in let before = match i.desc with - Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall(_, _)) + Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> Reg.Set.union before1 !spill_at_raise | _ -> before1 in - (instr_cons i.desc i.arg i.res + (instr_cons_debug i.desc i.arg i.res i.dbg (add_spills (Reg.inter_set_array after i.res) new_next), before) | Iifthenelse(test, ifso, ifnot) -> diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 06a09ed04..1fcbb0749 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -140,8 +140,8 @@ let rec rename i sub = end | Iop _ -> let (new_next, sub_next) = rename i.next sub in - (instr_cons i.desc (subst_regs i.arg sub) (subst_regs i.res sub) - new_next, + (instr_cons_debug i.desc (subst_regs i.arg sub) (subst_regs i.res sub) + i.dbg new_next, sub_next) | Iifthenelse(tst, ifso, ifnot) -> let (new_ifso, sub_ifso) = rename ifso sub in @@ -187,7 +187,7 @@ let rec rename i sub = (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next, sub_next) | Iraise -> - (instr_cons Iraise (subst_regs i.arg sub) [||] i.next, + (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next, None) (* Second pass: replace registers by their final representatives *) diff --git a/asmrun/Makefile b/asmrun/Makefile index cbdc94346..d4e8153ad 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -26,7 +26,7 @@ COBJS=startup.o main.o fail.o roots.o globroots.o signals.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o + compact.o finalise.o custom.o unix.o backtrace.o ASMOBJS=$(ARCH).o diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 647bee3a4..bf896a34d 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -23,7 +23,8 @@ COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) \ compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \ intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \ - weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) + weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \ + backtrace.$(O) LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 5fd5440cf..d61d521ef 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -247,14 +247,48 @@ FUNCTION(caml_start_program) orq $2, %rax jmp .L109 +/* Raise an exception from Caml */ + +FUNCTION(caml_raise_exn) + testl $1, caml_backtrace_active(%rip) + jne .L110 + movq %r14, %rsp + popq %r14 + ret +.L110: + movq %rax, %r12 /* Save exception bucket */ + movq %rax, %rdi /* arg 1: exception bucket */ + movq 0(%rsp), %rsi /* arg 2: pc of raise */ + leaq 8(%rsp), %rdx /* arg 3: sp of raise */ + movq %r14, %rcx /* arg 4: sp of handler */ + call caml_stash_backtrace + movq %r12, %rax /* Recover exception bucket */ + movq %r14, %rsp + popq %r14 + ret + /* Raise an exception from C */ FUNCTION(caml_raise_exception) + testl $1, caml_backtrace_active(%rip) + jne .L111 movq %rdi, %rax movq caml_exception_pointer(%rip), %rsp popq %r14 /* Recover previous exception handler */ movq caml_young_ptr(%rip), %r15 /* Reload alloc ptr */ ret +.L111: + movq %rdi, %r12 /* Save exception bucket */ + /* arg 1: exception bucket */ + movq caml_last_return_address(%rip), %rsi /* arg 2: pc of raise */ + movq caml_bottom_of_stack(%rip), %rdx /* arg 3: sp of raise */ + movq caml_exception_pointer(%rip), %rcx /* arg 4: sp of handler */ + call caml_stash_backtrace + movq %r12, %rax /* Recover exception bucket */ + movq caml_exception_pointer(%rip), %rsp + popq %r14 /* Recover previous exception handler */ + movq caml_young_ptr(%rip), %r15 /* Reload alloc ptr */ + ret /* Callback from C to Caml */ @@ -307,10 +341,8 @@ FUNCTION(caml_callback3_exn) jmp .L106 FUNCTION(caml_ml_array_bound_error) - /* Make the exception handler and alloc ptr available to the C code */ - movq %r15, caml_young_ptr(%rip) - movq %r14, caml_exception_pointer(%rip) - jmp caml_array_bound_error + leaq caml_array_bound_error(%rip), %rax + jmp caml_c_call .data .globl caml_system__frametable diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c new file mode 100644 index 000000000..50af17bb7 --- /dev/null +++ b/asmrun/backtrace.c @@ -0,0 +1,149 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2006 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +/* Stack backtrace for uncaught exceptions */ + +#include <stdio.h> +#include "backtrace.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "stack.h" + +int caml_backtrace_active = 0; +int caml_backtrace_pos = 0; +code_t * caml_backtrace_buffer = NULL; +value caml_backtrace_last_exn = Val_unit; +#define BACKTRACE_BUFFER_SIZE 1024 + +/* Initialize the backtrace machinery */ + +void caml_init_backtrace(void) +{ + caml_backtrace_active = 1; + caml_register_global_root(&caml_backtrace_last_exn); +} + +/* Store the return addresses contained in the given stack fragment + into the backtrace array */ + +void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) +{ + frame_descr * d; + uintnat h; + + if (exn != caml_backtrace_last_exn) { + caml_backtrace_pos = 0; + caml_backtrace_last_exn = exn; + } + if (caml_backtrace_buffer == NULL) { + caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); + if (caml_backtrace_buffer == NULL) return; + } + if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); + + while (1) { + /* Find the descriptor corresponding to the return address */ + h = Hash_retaddr(pc); + while(1) { + d = caml_frame_descriptors[h]; + if (d->retaddr == pc) break; + if (d->retaddr == 0) return; /* should not happen */ + h = (h+1) & caml_frame_descriptors_mask; + } + /* Skip to next frame */ + if (d->frame_size != 0xFFFF) { + /* Regular frame, store its descriptor in the backtrace buffer */ + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; + caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d; +#ifndef Stack_grows_upwards + sp += (d->frame_size & 0xFFFC); +#else + sp -= (d->frame_size & 0xFFFC); +#endif + pc = Saved_return_address(sp); +#ifdef Mask_already_scanned + pc = Mask_already_scanned(pc); +#endif + } else { + /* Special frame marking the top of a stack chunk for an ML callback. + Skip C portion of stack and continue with next ML stack chunk. */ + struct caml_context * next_context = Callback_link(sp); + sp = next_context->bottom_of_stack; + pc = next_context->last_retaddr; + /* A null sp means no more ML stack chunks; stop here. */ + if (sp == NULL) return; + } + /* Stop when we reach the current exception handler */ +#ifndef Stack_grows_upwards + if (sp > trapsp) return; +#else + if (sp < trapsp) return; +#endif + } +} + +/* Print a backtrace */ + +static void print_location(int index, frame_descr * d) +{ + uintnat infoptr; + uint32 info1, info2, k, n, l, a, b; + char * kind; + + /* If no debugging information available, print nothing. + When everything is compiled with -g, this corresponds to + compiler-inserted re-raise operations. */ + if ((d->frame_size & 1) == 0) return; + /* Recover debugging info */ + infoptr = ((uintnat) d + + sizeof(char *) + sizeof(short) + sizeof(short) + + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) + & -sizeof(frame_descr *); + info1 = ((uint32 *)infoptr)[0]; + info2 = ((uint32 *)infoptr)[1]; + /* Format of the two info words: + llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk + 44 36 26 2 0 + (32+12) (32+4) + k ( 2 bits): 0 if it's a call, 1 if it's a raise + n (24 bits): offset (in 4-byte words) of file name relative to infoptr + l (20 bits): line number + a ( 8 bits): beginning of character range + b (10 bits): end of character range */ + k = info1 & 3; + n = info1 & 0x3FFFFFC; + l = info2 >> 12; + a = (info2 >> 4) & 0xFF; + b = ((info2 & 0xF) << 6) | (info1 >> 26); + + if (index == 0) + kind = "Raised at"; + else if (k == 1) + kind = "Re-raised at"; + else + kind = "Called from"; + + fprintf(stderr, "%s file \"%s\", line %d, characters %d-%d\n", + kind, ((char *) infoptr) + n, l, a, b); +} + +void caml_print_exception_backtrace(void) +{ + int i; + + for (i = 0; i < caml_backtrace_pos; i++) + print_location(i, (frame_descr *) caml_backtrace_buffer[i]); +} diff --git a/asmrun/i386.S b/asmrun/i386.S index 518ebf3d5..16ea3381e 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -70,6 +70,14 @@ #define PROFILE_C #endif +#ifdef SYS_macosx +#define ALIGN_STACK(amount) subl $ amount, %esp +#define UNDO_ALIGN_STACK(amount) addl $ amount, %esp +#else +#define ALIGN_STACK(amount) +#define UNDO_ALIGN_STACK(amount) +#endif + /* Allocation */ .text @@ -79,6 +87,7 @@ .globl G(caml_alloc3) .globl G(caml_allocN) + .align FUNCTION_ALIGN G(caml_call_gc): PROFILE_CAML /* Record lowest stack address and return address */ @@ -124,13 +133,9 @@ LBL(100): movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) -#ifdef SYS_macosx - subl $12, %esp /* 16-alignment */ -#endif + ALIGN_STACK(12) call LBL(105) -#ifdef SYS_macosx - addl $12, %esp /* undo 16-alignment */ -#endif + UNDO_ALIGN_STACK(12) jmp G(caml_alloc1) .align FUNCTION_ALIGN @@ -147,13 +152,9 @@ LBL(101): movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) -#ifdef SYS_macosx - subl $12, %esp /* 16-alignment */ -#endif + ALIGN_STACK(12) call LBL(105) -#ifdef SYS_macosx - addl $12, %esp /* undo 16-alignment */ -#endif + UNDO_ALIGN_STACK(12) jmp G(caml_alloc2) .align FUNCTION_ALIGN @@ -170,13 +171,9 @@ LBL(102): movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) -#ifdef SYS_macosx - subl $12, %esp /* 16-alignment */ -#endif + ALIGN_STACK(12) call LBL(105) -#ifdef SYS_macosx - addl $12, %esp /* undo 16-alignment */ -#endif + UNDO_ALIGN_STACK(12) jmp G(caml_alloc3) .align FUNCTION_ALIGN @@ -197,13 +194,9 @@ LBL(103): movl %eax, G(caml_last_return_address) leal 8(%esp), %eax movl %eax, G(caml_bottom_of_stack) -#ifdef SYS_macosx - subl $8, %esp /* 16-alignment */ -#endif + ALIGN_STACK(8) call LBL(105) -#ifdef SYS_macosx - addl $8, %esp /* undo 16-alignment */ -#endif + UNDO_ALIGN_STACK(8) popl %eax /* recover desired size */ jmp G(caml_allocN) @@ -243,9 +236,7 @@ LBL(106): /* Note: 16-alignment preserved on MacOSX at this point */ /* Build an exception handler */ pushl $ LBL(108) -#ifdef SYS_macosx - subl $8, %esp /* 16-alignment */ -#endif + ALIGN_STACK(8) pushl G(caml_exception_pointer) movl %esp, G(caml_exception_pointer) /* Call the Caml code */ @@ -276,18 +267,59 @@ LBL(108): orl $2, %eax jmp LBL(109) +/* Raise an exception from Caml */ + + .globl G(caml_raise_exn) + .align FUNCTION_ALIGN +G(caml_raise_exn): + testl $1, G(caml_backtrace_active) + jne LBL(110) + movl G(caml_exception_pointer), %esp + popl G(caml_exception_pointer) + UNDO_ALIGN_STACK(8) + ret +LBL(110): + movl %eax, %esi /* Save exception bucket in esi */ + movl G(caml_exception_pointer), %edi /* SP of handler */ + movl 0(%esp), %eax /* PC of raise */ + leal 4(%esp), %edx /* SP of raise */ + ALIGN_STACK(12) + pushl %edi /* arg 4: sp of handler */ + pushl %edx /* arg 3: sp of raise */ + pushl %eax /* arg 2: pc of raise */ + pushl %esi /* arg 1: exception bucket */ + call G(caml_stash_backtrace) + movl %esi, %eax /* Recover exception bucket */ + movl %edi, %esp + popl G(caml_exception_pointer) + UNDO_ALIGN_STACK(8) + ret + /* Raise an exception from C */ .globl G(caml_raise_exception) .align FUNCTION_ALIGN G(caml_raise_exception): PROFILE_C + testl $1, G(caml_backtrace_active) + jne LBL(111) movl 4(%esp), %eax movl G(caml_exception_pointer), %esp popl G(caml_exception_pointer) -#ifdef SYS_macosx - addl $8, %esp -#endif + UNDO_ALIGN_STACK(8) + ret +LBL(111): + movl 4(%esp), %esi /* Save exception bucket in esi */ + ALIGN_STACK(12) + pushl G(caml_exception_pointer) /* arg 4: sp of handler */ + pushl G(caml_bottom_of_stack) /* arg 3: sp of raise */ + pushl G(caml_last_return_address) /* arg 2: pc of raise */ + pushl %esi /* arg 1: exception bucket */ + call G(caml_stash_backtrace) + movl %esi, %eax /* Recover exception bucket */ + movl G(caml_exception_pointer), %esp + popl G(caml_exception_pointer) + UNDO_ALIGN_STACK(8) ret /* Callback from C to Caml */ @@ -353,7 +385,8 @@ G(caml_ml_array_bound_error): ffree %st(6) ffree %st(7) /* Branch to [caml_array_bound_error] */ - jmp G(caml_array_bound_error) + movl $ G(caml_array_bound_error), %eax + jmp caml_c_call .data .globl G(caml_system__frametable) diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm index b2a2614c3..7d51a7ec1 100644 --- a/asmrun/i386nt.asm +++ b/asmrun/i386nt.asm @@ -29,6 +29,8 @@ EXTERN _caml_last_return_address: DWORD EXTERN _caml_gc_regs: DWORD EXTERN _caml_exception_pointer: DWORD + EXTERN _caml_backtrace_active: DWORD + EXTERN _caml_stash_backtrace: PROC ; Allocation @@ -194,15 +196,53 @@ L108: or eax, 2 jmp L109 +; Raise an exception for Caml + + PUBLIC _caml_raise_exn + ALIGN 4 +_caml_raise_exn: + test _caml_backtrace_active, 1 + jne L110 + mov esp, _caml_exception_pointer + pop _caml_exception_pointer + ret +L110: + mov esi, eax ; Save exception bucket in esi + mov edi, _caml_exception_pointer ; SP of handler + mov eax, [esp] ; PC of raise + lea edx, [esp+4] + push edi ; arg 4: SP of handler + push edx ; arg 3: SP of raise + push eax ; arg 2: PC of raise + push esi ; arg 1: exception bucket + call _caml_stash_backtrace + mov eax, esi ; recover exception bucket + mov esp, edi ; cut the stack + pop _caml_exception_pointer + ret + ; Raise an exception from C PUBLIC _caml_raise_exception ALIGN 4 _caml_raise_exception: + test _caml_backtrace_active, 1 + jne L111 mov eax, [esp+4] mov esp, _caml_exception_pointer pop _caml_exception_pointer ret +L111: + mov esi, [esp+4] ; Save exception bucket in esi + push _caml_exception_pointer ; arg 4: SP of handler + push _caml_bottom_of_stack ; arg 3: SP of raise + push _caml_last_return_address ; arg 2: PC of raise + push esi ; arg 1: exception bucket + call _caml_stash_backtrace + mov eax, esi ; recover exception bucket + mov esp, _caml_exception_pointer ; cut the stack + pop _caml_exception_pointer + ret ; Callback from C to Caml @@ -263,8 +303,9 @@ _caml_ml_array_bound_error: ffree st(5) ffree st(6) ffree st(7) - ; Branch to array_bound_error - jmp _caml_array_bound_error + ; Branch to caml_array_bound_error + mov eax, offset _caml_array_bound_error + jmp _caml_c_call .DATA PUBLIC _caml_system__frametable diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S index 370d201dc..765de9c8c 100644 --- a/asmrun/power-rhapsody.S +++ b/asmrun/power-rhapsody.S @@ -220,10 +220,43 @@ _caml_c_call: /* Return to caller */ blr +/* Raise an exception from Caml */ + .globl _caml_raise_exn +_caml_raise_exn: + addis r11, 0, ha16(_caml_backtrace_active) + lwz r11, lo16(_caml_backtrace_active)(r11) + cmpwi r11, 0 + bne L110 +L111: + /* Pop trap frame */ + lg r0, 0(r29) + mr r1, r29 + mtlr r0 + lg r29, WORD(r1) + addi r1, r1, 16 + /* Branch to handler */ + blr + +L110: + mr r28, r3 /* preserve exn bucket in callee-save */ + /* arg 1: exception bucket (already in r3) */ + mflr r4 /* arg 2: PC of raise */ + mr r5, r1 /* arg 3: SP of raise */ + mr r6, r29 /* arg 4: SP of handler */ + addi r1, r1, -(16*WORD) /* reserve stack space for C call */ + bl _caml_stash_backtrace + mr r3, r28 + b L111 + /* Raise an exception from C */ .globl _caml_raise_exception _caml_raise_exception: + addis r11, 0, ha16(_caml_backtrace_active) + lwz r11, lo16(_caml_backtrace_active)(r11) + cmpwi r11, 0 + bne L112 +L113: /* Reload Caml global registers */ Loadglobal r1, _caml_exception_pointer, r11 Loadglobal r31, _caml_young_ptr, r11 @@ -238,6 +271,16 @@ _caml_raise_exception: addi r1, r1, 16 /* Branch to handler */ blr +L112: + mr r28, r3 /* preserve exn bucket in callee-save */ + /* arg 1: exception bucket (already in r3) */ + Loadglobal r4, _caml_last_return_address, r11 /* arg 2: PC of raise */ + Loadglobal r5, _caml_bottom_of_stack, r11 /* arg 3: SP of raise */ + Loadglobal r6, _caml_exception_pointer, r11 /* arg 4: SP of handler */ + addi r1, r1, -(16*WORD) /* reserve stack space for C call */ + bl _caml_stash_backtrace + mr r3, r28 + b L113 /* Start the Caml program */ diff --git a/asmrun/roots.c b/asmrun/roots.c index 5a143d2dd..f5ff1591e 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -33,24 +33,15 @@ void (*caml_scan_roots_hook) (scanning_action) = NULL; /* The hashtable of frame descriptors */ -typedef struct { - uintnat retaddr; - short frame_size; - short num_live; - short live_ofs[1]; -} frame_descr; - -static frame_descr ** frame_descriptors = NULL; -static int frame_descriptors_mask; - -#define Hash_retaddr(addr) \ - (((uintnat)(addr) >> 3) & frame_descriptors_mask) +frame_descr ** caml_frame_descriptors = NULL; +int caml_frame_descriptors_mask; -static void init_frame_descriptors(void) +void caml_init_frame_descriptors(void) { intnat num_descr, tblsize, i, j, len; intnat * tbl; frame_descr * d; + uintnat nextd; uintnat h; /* Count the frame descriptors */ @@ -64,10 +55,10 @@ static void init_frame_descriptors(void) while (tblsize < 2 * num_descr) tblsize *= 2; /* Allocate the hash table */ - frame_descriptors = + caml_frame_descriptors = (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *)); - for (i = 0; i < tblsize; i++) frame_descriptors[i] = NULL; - frame_descriptors_mask = tblsize - 1; + for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL; + caml_frame_descriptors_mask = tblsize - 1; /* Fill the hash table */ for (i = 0; caml_frametable[i] != 0; i++) { @@ -76,15 +67,17 @@ static void init_frame_descriptors(void) d = (frame_descr *)(tbl + 1); for (j = 0; j < len; j++) { h = Hash_retaddr(d->retaddr); - while (frame_descriptors[h] != NULL) { - h = (h+1) & frame_descriptors_mask; + while (caml_frame_descriptors[h] != NULL) { + h = (h+1) & caml_frame_descriptors_mask; } - frame_descriptors[h] = d; - d = (frame_descr *) - (((uintnat)d + - sizeof(char *) + sizeof(short) + sizeof(short) + - sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) - & -sizeof(frame_descr *)); + caml_frame_descriptors[h] = d; + nextd = + ((uintnat)d + + sizeof(char *) + sizeof(short) + sizeof(short) + + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) + & -sizeof(frame_descr *); + if (d->frame_size & 1) nextd += 8; + d = (frame_descr *) nextd; } } } @@ -107,7 +100,7 @@ void caml_oldify_local_roots (void) frame_descr * d; uintnat h; int i, j, n, ofs; - short * p; + unsigned short * p; value glob; value * root; struct global_root * gr; @@ -125,7 +118,7 @@ void caml_oldify_local_roots (void) caml_globals_scanned = caml_globals_inited; /* The stack and local roots */ - if (frame_descriptors == NULL) init_frame_descriptors(); + if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); sp = caml_bottom_of_stack; retaddr = caml_last_return_address; regs = caml_gc_regs; @@ -134,11 +127,11 @@ void caml_oldify_local_roots (void) /* Find the descriptor corresponding to the return address */ h = Hash_retaddr(retaddr); while(1) { - d = frame_descriptors[h]; + d = caml_frame_descriptors[h]; if (d->retaddr == retaddr) break; - h = (h+1) & frame_descriptors_mask; + h = (h+1) & caml_frame_descriptors_mask; } - if (d->frame_size >= 0) { + if (d->frame_size != 0xFFFF) { /* Scan the roots in this frame */ for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { ofs = *p; @@ -151,9 +144,9 @@ void caml_oldify_local_roots (void) } /* Move to next frame */ #ifndef Stack_grows_upwards - sp += d->frame_size; + sp += (d->frame_size & 0xFFFC); #else - sp -= d->frame_size; + sp -= (d->frame_size & 0xFFFC); #endif retaddr = Saved_return_address(sp); #ifdef Already_scanned @@ -213,7 +206,7 @@ void caml_do_roots (scanning_action f) f (Field (glob, j), &Field (glob, j)); } /* The stack and local roots */ - if (frame_descriptors == NULL) init_frame_descriptors(); + if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address, caml_gc_regs, caml_local_roots); /* Global C roots */ @@ -236,7 +229,7 @@ void caml_do_local_roots(scanning_action f, char * bottom_of_stack, frame_descr * d; uintnat h; int i, j, n, ofs; - short * p; + unsigned short * p; value * root; struct caml__roots_block *lr; @@ -248,11 +241,11 @@ void caml_do_local_roots(scanning_action f, char * bottom_of_stack, /* Find the descriptor corresponding to the return address */ h = Hash_retaddr(retaddr); while(1) { - d = frame_descriptors[h]; + d = caml_frame_descriptors[h]; if (d->retaddr == retaddr) break; - h = (h+1) & frame_descriptors_mask; + h = (h+1) & caml_frame_descriptors_mask; } - if (d->frame_size >= 0) { + if (d->frame_size != 0xFFFF) { /* Scan the roots in this frame */ for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { ofs = *p; @@ -265,9 +258,9 @@ void caml_do_local_roots(scanning_action f, char * bottom_of_stack, } /* Move to next frame */ #ifndef Stack_grows_upwards - sp += d->frame_size; + sp += (d->frame_size & 0xFFFC); #else - sp -= d->frame_size; + sp -= (d->frame_size & 0xFFFC); #endif retaddr = Saved_return_address(sp); #ifdef Mask_already_scanned diff --git a/asmrun/signals.c b/asmrun/signals.c index 30d9402f4..38f6c4085 100644 --- a/asmrun/signals.c +++ b/asmrun/signals.c @@ -391,6 +391,10 @@ DECLARE_SIGNAL_HANDLER(trap_handler) #endif caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; +#if defined(SYS_rhapsody) + caml_bottom_of_stack = (char *) CONTEXT_SP; + caml_last_return_address = (uintnat) CONTEXT_PC; +#endif caml_array_bound_error(); } #endif diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 642ac7793..f34863b39 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -133,6 +133,7 @@ #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.r30) #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.r31) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + #define CONTEXT_SP (CONTEXT_STATE.r1) #else @@ -152,6 +153,7 @@ #define CONTEXT_YOUNG_LIMIT (*context_gpr_p(context, 30)) #define CONTEXT_YOUNG_PTR (*context_gpr_p(context, 31)) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + #define CONTEXT_SP (*context_gpr_p(context, 1)) static int ctx_version = 0; static void init_ctx (void) diff --git a/asmrun/stack.h b/asmrun/stack.h index e8d1b5807..913ec4f55 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -96,6 +96,25 @@ struct caml_context { value * gc_regs; /* pointer to register block */ }; +/* Structure of frame descriptors */ + +typedef struct { + uintnat retaddr; + unsigned short frame_size; + unsigned short num_live; + unsigned short live_ofs[1]; +} frame_descr; + +/* Hash table of frame descriptors */ + +extern frame_descr ** caml_frame_descriptors; +extern int caml_frame_descriptors_mask; + +#define Hash_retaddr(addr) \ + (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask) + +extern void caml_init_frame_descriptors(void); + /* Declaration of variables used in the asm code */ extern char * caml_bottom_of_stack; extern uintnat caml_last_return_address; diff --git a/asmrun/startup.c b/asmrun/startup.c index 44aab0ccf..765d2a8bf 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -18,6 +18,7 @@ #include <stdio.h> #include <stdlib.h> #include "callback.h" +#include "backtrace.h" #include "custom.h" #include "fail.h" #include "gc.h" @@ -110,6 +111,7 @@ static void parse_camlrunparam(void) case 'o': scanmult (opt, &percent_free_init); break; case 'O': scanmult (opt, &max_percent_free_init); break; case 'v': scanmult (opt, &caml_verb_gc); break; + case 'b': caml_init_backtrace(); break; case 'p': caml_parser_trace = 1; break; } } diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex bf2397901..4ab8cf797 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 0579e2878..7b91e2103 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/byterun/backtrace.c b/byterun/backtrace.c index cdc8b684b..2606020de 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -170,7 +170,7 @@ static value event_for_location(value events, code_t pc) static void print_location(value events, int index) { - code_t pc = caml_backtrace_buffer[index]; + code_t pc = caml_backtrace_buffer[index]; char * info; value ev; diff --git a/byterun/backtrace.h b/byterun/backtrace.h index be8c48289..3e35b434f 100644 --- a/byterun/backtrace.h +++ b/byterun/backtrace.h @@ -24,7 +24,9 @@ CAMLextern code_t * caml_backtrace_buffer; CAMLextern value caml_backtrace_last_exn; extern void caml_init_backtrace(void); +#ifndef NATIVE_CODE extern void caml_stash_backtrace(value exn, code_t pc, value * sp); +#endif CAMLextern void caml_print_exception_backtrace(void); #endif /* CAML_BACKTRACE_H */ diff --git a/byterun/meta.c b/byterun/meta.c index ac86ee8e1..78f0b57b3 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -160,14 +160,9 @@ value * caml_stack_high; value * caml_stack_threshold; value * caml_extern_sp; value * caml_trapsp; -int caml_backtrace_active; -int caml_backtrace_pos; -code_t * caml_backtrace_buffer; -value caml_backtrace_last_exn; int caml_callback_depth; int volatile caml_something_to_do; void (* volatile caml_async_action_hook)(void); -void caml_print_exception_backtrace(void) { } struct longjmp_buffer * caml_external_raise; #endif diff --git a/byterun/printexc.c b/byterun/printexc.c index 371b30a08..c2f0af046 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -97,33 +97,30 @@ void caml_fatal_uncaught_exception(value exn) { char * msg; value * at_exit; -#ifndef NATIVE_CODE int saved_backtrace_active, saved_backtrace_pos; -#endif + /* Build a string representation of the exception */ msg = caml_format_exception(exn); /* Perform "at_exit" processing, ignoring all exceptions that may be triggered by this */ -#ifndef NATIVE_CODE saved_backtrace_active = caml_backtrace_active; saved_backtrace_pos = caml_backtrace_pos; caml_backtrace_active = 0; -#endif at_exit = caml_named_value("Pervasives.do_at_exit"); if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit); -#ifndef NATIVE_CODE caml_backtrace_active = saved_backtrace_active; caml_backtrace_pos = saved_backtrace_pos; -#endif /* Display the uncaught exception */ fprintf(stderr, "Fatal error: exception %s\n", msg); free(msg); /* Display the backtrace if available */ + if (caml_backtrace_active #ifndef NATIVE_CODE - if (caml_backtrace_active && !caml_debugger_in_use){ + && !caml_debugger_in_use +#endif + ) { caml_print_exception_backtrace(); } -#endif /* Terminate the process */ exit(2); } diff --git a/driver/optmain.ml b/driver/optmain.ml index faef184c9..06b4aadfe 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -114,6 +114,7 @@ let main () = "-for-pack", Arg.String (fun s -> for_package := Some s), "<ident> Generate code that can later be `packed' with\n\ \ ocamlopt -pack -o <ident>.cmx"; + "-g", Arg.Set debug, " Record debugging information for exception backtrace"; "-i", Arg.Unit (fun () -> print_types := true; compile_only := true), " Print inferred interface"; "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs), diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile index 9b4e44257..9102b5b97 100644 --- a/otherlibs/bigarray/Makefile +++ b/otherlibs/bigarray/Makefile @@ -20,7 +20,7 @@ CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) CAMLC=../../ocamlcomp.sh -I ../unix CAMLOPT=../../ocamlcompopt.sh -I ../unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g C_OBJS=bigarray_stubs.o mmap_unix.o diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt index b4a8dc305..b90f049ac 100644 --- a/otherlibs/bigarray/Makefile.nt +++ b/otherlibs/bigarray/Makefile.nt @@ -19,6 +19,7 @@ CC=$(BYTECC) CFLAGS=-I../../byterun -I../win32unix -DIN_OCAML_BIGARRAY CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix +COMPFLAGS=-warn-error A -g C_OBJS=bigarray_stubs.obj mmap_win32.obj diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile index d0677326d..d9f5c1abb 100644 --- a/otherlibs/graph/Makefile +++ b/otherlibs/graph/Makefile @@ -22,7 +22,7 @@ CFLAGS=-I../../byterun $(X11_INCLUDES) -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) CAMLC=../../ocamlcomp.sh CAMLOPT=../../ocamlcompopt.sh MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g OBJS=open.o draw.o fill.o color.o text.o \ image.o make_img.o dump_img.o point_col.o sound.o events.o \ diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common index 7e8bfadba..b8aa786f7 100644 --- a/otherlibs/labltk/support/Makefile.common +++ b/otherlibs/labltk/support/Makefile.common @@ -20,7 +20,7 @@ CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex CAMLLIBR=$(CAMLC) -a CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep -COMPFLAGS= +COMPFLAGS=-g LINKFLAGS= CAMLOPTLIBR=$(CAMLOPT) -a MKLIB=$(CAMLRUN) $(TOPDIR)/tools/ocamlmklib diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile index 8a561e888..59af1a6d9 100644 --- a/otherlibs/num/Makefile +++ b/otherlibs/num/Makefile @@ -24,7 +24,7 @@ CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ CAMLC=../../ocamlcomp.sh CAMLOPT=../../ocamlcompopt.sh MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ ratio.cmo num.cmo arith_status.cmo diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt index 524a3b1a4..3599bd221 100644 --- a/otherlibs/num/Makefile.nt +++ b/otherlibs/num/Makefile.nt @@ -23,6 +23,7 @@ CFLAGS=-I../../byterun \ -DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL) CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot -w s CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -w s +COMPFLAGS=-warn-error A -g CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ ratio.cmo num.cmo arith_status.cmo diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile index 97123ddaa..4caefdb17 100644 --- a/otherlibs/str/Makefile +++ b/otherlibs/str/Makefile @@ -22,7 +22,7 @@ CC=$(BYTECC) CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) CAMLC=../../ocamlcomp.sh CAMLOPT=../../ocamlcompopt.sh -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g COBJS=strstubs.o MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt index 3d65d19f0..5442bbc18 100644 --- a/otherlibs/str/Makefile.nt +++ b/otherlibs/str/Makefile.nt @@ -22,6 +22,7 @@ CC=$(BYTECC) CFLAGS=-I../../byterun CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib +COMPFLAGS=-warn-error A -g DCOBJS=strstubs.$(DO) SCOBJS=strstubs.$(SO) diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index 5c16a8a3b..45d0e7ee1 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -18,7 +18,7 @@ include ../../config/Makefile CAMLC=../../ocamlcomp.sh -I ../unix CAMLOPT=../../ocamlcompopt.sh -I ../unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g BYTECODE_C_OBJS=posix_b.o NATIVECODE_C_OBJS=posix_n.o @@ -90,7 +90,7 @@ installopt: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmo: - $(CAMLC) -c -g $(COMPFLAGS) $< + $(CAMLC) -c $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt index 530a08e5e..be5ce4add 100644 --- a/otherlibs/systhreads/Makefile.nt +++ b/otherlibs/systhreads/Makefile.nt @@ -18,6 +18,7 @@ include ../../config/Makefile # Compilation options CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix +COMPFLAGS=-warn-error A -g THREAD_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index fcd0f505d..679fb09b4 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -88,10 +88,10 @@ struct caml_thread_struct { value * trapsp; /* Saved value of trapsp for this thread */ struct caml__roots_block * local_roots; /* Saved value of local_roots */ struct longjmp_buffer * external_raise; /* Saved external_raise */ +#endif int backtrace_pos; /* Saved backtrace_pos */ code_t * backtrace_buffer; /* Saved backtrace_buffer */ value backtrace_last_exn; /* Saved backtrace_last_exn (root) */ -#endif }; typedef struct caml_thread_struct * caml_thread_t; @@ -147,9 +147,7 @@ static void caml_thread_scan_roots(scanning_action action) th = curr_thread; do { (*action)(th->descr, &th->descr); -#ifndef NATIVE_CODE (*action)(th->backtrace_last_exn, &th->backtrace_last_exn); -#endif /* Don't rescan the stack of the current thread, it was done already */ if (th != curr_thread) { #ifdef NATIVE_CODE @@ -186,10 +184,10 @@ static void caml_thread_enter_blocking_section(void) curr_thread->trapsp = trapsp; curr_thread->local_roots = local_roots; curr_thread->external_raise = external_raise; +#endif curr_thread->backtrace_pos = backtrace_pos; curr_thread->backtrace_buffer = backtrace_buffer; curr_thread->backtrace_last_exn = backtrace_last_exn; -#endif /* Tell other threads that the runtime is free */ pthread_mutex_lock(&caml_runtime_mutex); caml_runtime_busy = 0; @@ -226,10 +224,10 @@ static void caml_thread_leave_blocking_section(void) trapsp = curr_thread->trapsp; local_roots = curr_thread->local_roots; external_raise = curr_thread->external_raise; +#endif backtrace_pos = curr_thread->backtrace_pos; backtrace_buffer = curr_thread->backtrace_buffer; backtrace_last_exn = curr_thread->backtrace_last_exn; -#endif } static int caml_thread_try_leave_blocking_section(void) @@ -409,8 +407,8 @@ static void caml_thread_stop(void) #ifndef NATIVE_CODE /* Free the memory resources */ stat_free(th->stack_low); - if (th->backtrace_buffer != NULL) free(th->backtrace_buffer); #endif + if (th->backtrace_buffer != NULL) free(th->backtrace_buffer); /* Free the thread descriptor */ stat_free(th); } @@ -479,10 +477,10 @@ value caml_thread_new(value clos) /* ML */ th->trapsp = th->stack_high; th->local_roots = NULL; th->external_raise = NULL; +#endif th->backtrace_pos = 0; th->backtrace_buffer = NULL; th->backtrace_last_exn = Val_unit; -#endif /* Add thread info block to the list of threads */ th->next = curr_thread->next; th->prev = curr_thread; @@ -529,9 +527,7 @@ value caml_thread_uncaught_exception(value exn) /* ML */ fprintf(stderr, "Thread %d killed on uncaught exception %s\n", Int_val(Ident(curr_thread->descr)), msg); free(msg); -#ifndef NATIVE_CODE - if (backtrace_active) print_exception_backtrace(); -#endif + if (caml_backtrace_active) print_exception_backtrace(); fflush(stderr); return Val_unit; } diff --git a/otherlibs/threads/Tests/Makefile b/otherlibs/threads/Tests/Makefile index 6bf52ef05..be271f469 100644 --- a/otherlibs/threads/Tests/Makefile +++ b/otherlibs/threads/Tests/Makefile @@ -33,6 +33,6 @@ sorts.byt: sorts.ml .SUFFIXES: .ml .byt .ml.byt: - $(CAMLC) -o $*.byt unix.cma threads.cma $*.ml $(LIBS) + $(CAMLC) -custom -o $*.byt unix.cma threads.cma $*.ml $(LIBS) -$(PROGS): ../threads.cma ../libthreads.a +$(PROGS): ../threads.cma ../libvmthreads.a diff --git a/otherlibs/threads/Tests/testsignal2.ml b/otherlibs/threads/Tests/testsignal2.ml index 1f7fc0f91..c73bdb995 100644 --- a/otherlibs/threads/Tests/testsignal2.ml +++ b/otherlibs/threads/Tests/testsignal2.ml @@ -4,6 +4,7 @@ let print_message delay c = done let _ = + Thread.sigmask Unix.SIG_BLOCK [Sys.sigint; Sys.sigterm]; let th1 = Thread.create (print_message 0.6666666666) 'a' in let th2 = Thread.create (print_message 1.0) 'b' in let s = Thread.wait_signal [Sys.sigint; Sys.sigterm] in diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile index c9ce69c4a..12dc2d898 100644 --- a/otherlibs/unix/Makefile +++ b/otherlibs/unix/Makefile @@ -23,7 +23,7 @@ CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) CAMLC=../../ocamlcomp.sh CAMLOPT=../../ocamlcompopt.sh MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \ chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o \ diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt index 18c6410cb..4c2f9b92a 100644 --- a/otherlibs/win32graph/Makefile.nt +++ b/otherlibs/win32graph/Makefile.nt @@ -20,7 +20,7 @@ CC=$(BYTECC) CFLAGS=-I../../byterun CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O) CAMLOBJS=graphics.cmo diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt index b288bdbf4..f9408a643 100644 --- a/otherlibs/win32unix/Makefile.nt +++ b/otherlibs/win32unix/Makefile.nt @@ -20,7 +20,7 @@ CC=$(BYTECC) CFLAGS=-I../../byterun -I../unix CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g # Files in this directory WIN_FILES = accept.c bind.c channels.c close.c \ diff --git a/stdlib/Makefile b/stdlib/Makefile index 8817d5690..d2de5074b 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -21,7 +21,7 @@ CAMLC=$(RUNTIME) $(COMPILER) COMPFLAGS=-g -warn-error A -nostdlib OPTCOMPILER=../ocamlopt CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib +OPTCOMPFLAGS=-warn-error A -nostdlib -g CAMLDEP=../boot/ocamlrun ../tools/ocamldep OBJS=pervasives.cmo $(OTHERS) diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt index 3d9e6c443..f29a583de 100644 --- a/stdlib/Makefile.nt +++ b/stdlib/Makefile.nt @@ -21,7 +21,7 @@ CAMLC=$(RUNTIME) $(COMPILER) COMPFLAGS=-warn-error A -nostdlib OPTCOMPILER=../ocamlopt CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib +OPTCOMPFLAGS=-warn-error A -nostdlib -g CAMLDEP=../boot/ocamlrun ../tools/ocamldep OBJS=pervasives.cmo $(OTHERS) diff --git a/test/Makefile b/test/Makefile index 84ac56574..b822b35a8 100644 --- a/test/Makefile +++ b/test/Makefile @@ -17,7 +17,7 @@ include ../config/Makefile CAMLC=../boot/ocamlrun ../ocamlc CAMLOPT=../boot/ocamlrun ../ocamlopt COMPFLAGS=-nostdlib -I ../stdlib -I KB -I Lex -OPTFLAGS=-S +OPTFLAGS=-S -g CAMLYACC=../yacc/ocamlyacc YACCFLAGS=-v CAMLLEX=../boot/ocamlrun ../lex/ocamllex diff --git a/test/Moretest/Makefile b/test/Moretest/Makefile index 987530607..f8b0c8bcc 100644 --- a/test/Moretest/Makefile +++ b/test/Moretest/Makefile @@ -16,7 +16,7 @@ include ../../config/Makefile CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -OPTFLAGS=-S +OPTFLAGS=-S -g CAMLDEP=../../boot/ocamlrun ../../tools/ocamldep CAMLRUN=../../byterun/ocamlrun CODERUNPARAMS=OCAMLRUNPARAM='o=100' diff --git a/test/Moretest/backtrace.ml b/test/Moretest/backtrace.ml new file mode 100644 index 000000000..27dbe8f0d --- /dev/null +++ b/test/Moretest/backtrace.ml @@ -0,0 +1,56 @@ +(* A test for stack backtraces *) + +exception Error of string + +let rec f msg n = + if n = 0 then raise(Error msg) else 1 + f msg (n-1) + +let g msg = + try + f msg 5 + with Error "a" -> print_string "a"; print_newline(); 0 + | Error "b" as exn -> print_string "b"; print_newline(); raise exn + | Error "c" -> raise (Error "c") + +let _ = + ignore (g Sys.argv.(1)) + +(* Expected results: + +OCAMLRUNPARAM=b=1 ./backtrace.out a +a + +OCAMLRUNPARAM=b=1 ./backtrace.out b +b +Fatal error: exception Backtrace.Error("b") +Raised at file "backtrace.ml", line 6, characters 21-32 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 10, characters 4-11 +Re-raised at file "backtrace.ml", line 12, characters 68-71 +Called from file "backtrace.ml", line 16, characters 9-25 + +OCAMLRUNPARAM=b=1 ./backtrace.out c +Fatal error: exception Backtrace.Error("c") +Raised at file "backtrace.ml", line 13, characters 26-37 +Called from file "backtrace.ml", line 16, characters 9-25 + +OCAMLRUNPARAM=b=1 ./backtrace.out d +Fatal error: exception Backtrace.Error("d") +Raised at file "backtrace.ml", line 6, characters 21-32 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 6, characters 42-53 +Called from file "backtrace.ml", line 10, characters 4-11 +Called from file "backtrace.ml", line 16, characters 9-25 + +OCAMLRUNPARAM=b=1 ./backtrace.out +Fatal error: exception Invalid_argument("index out of bounds") +Raised at file "backtrace.ml", line 16, characters 12-24 + +*) diff --git a/utils/config.mlp b/utils/config.mlp index f92362a1d..7106c8f39 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -43,7 +43,7 @@ let exec_magic_number = "Caml1999X008" and cmi_magic_number = "Caml1999I010" and cmo_magic_number = "Caml1999O006" and cma_magic_number = "Caml1999A007" -and cmx_magic_number = "Caml1999Y010" +and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" and ast_impl_magic_number = "Caml1999M011" and ast_intf_magic_number = "Caml1999N010" |