Skip to content

Instantly share code, notes, and snippets.

@emillon

emillon/zamcov-ocaml.patch

Created June 20, 2014 13:06
Show Gist options
  • Save emillon/6f1a866fd44c046e066f to your computer and use it in GitHub Desktop.
Save emillon/6f1a866fd44c046e066f to your computer and use it in GitHub Desktop.
Download ZIP
zamcov 2
Raw
zamcov-ocaml.patch
Binary files ocaml-3.12.0/.DS_Store and ocaml-diff/.DS_Store differ
diff -urN ocaml-3.12.0/.depend ocaml-diff/.depend
--- ocaml-3.12.0/.depend 2010-07-23 17:30:37.000000000 +0200
+++ ocaml-diff/.depend 2012-03-14 14:42:30.000000000 +0100
@@ -291,12 +291,17 @@
bytecomp/bytepackager.cmi: typing/ident.cmi
bytecomp/bytesections.cmi:
bytecomp/cmo_format.cmi: bytecomp/lambda.cmi typing/ident.cmi
+bytecomp/covevent.cmi: typing/types.cmi parsing/location.cmi
+bytecomp/covutils.cmi: typing/typedtree.cmi typing/primitive.cmi \
+ bytecomp/lambda.cmi bytecomp/instruct.cmi bytecomp/covevent.cmi \
+ bytecomp/cmo_format.cmi
bytecomp/dll.cmi:
bytecomp/emitcode.cmi: bytecomp/instruct.cmi bytecomp/cmo_format.cmi
bytecomp/instruct.cmi: typing/types.cmi typing/subst.cmi parsing/location.cmi \
- bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
+ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/covevent.cmi
bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \
- parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
+ parsing/location.cmi typing/ident.cmi typing/env.cmi \
+ bytecomp/covevent.cmi parsing/asttypes.cmi
bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \
bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
bytecomp/meta.cmi:
@@ -318,12 +323,14 @@
bytecomp/lambda.cmi
bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \
typing/stypes.cmi typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
- bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \
- parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
+ bytecomp/instruct.cmi typing/ident.cmi bytecomp/covutils.cmi \
+ utils/config.cmi parsing/asttypes.cmi typing/annot.cmi \
+ bytecomp/bytegen.cmi
bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \
typing/stypes.cmx typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
- bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \
- parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
+ bytecomp/instruct.cmx typing/ident.cmx bytecomp/covutils.cmx \
+ utils/config.cmx parsing/asttypes.cmi typing/annot.cmi \
+ bytecomp/bytegen.cmi
bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \
bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
bytecomp/bytelibrarian.cmi
@@ -332,14 +339,14 @@
bytecomp/bytelibrarian.cmi
bytecomp/bytelink.cmo: bytecomp/symtable.cmi bytecomp/opcodes.cmo \
utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi bytecomp/dll.cmi \
- utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \
- utils/clflags.cmi utils/ccomp.cmi bytecomp/bytesections.cmi \
- bytecomp/bytelink.cmi
+ bytecomp/covutils.cmi utils/consistbl.cmi utils/config.cmi \
+ bytecomp/cmo_format.cmi utils/clflags.cmi utils/ccomp.cmi \
+ bytecomp/bytesections.cmi bytecomp/bytelink.cmi
bytecomp/bytelink.cmx: bytecomp/symtable.cmx bytecomp/opcodes.cmx \
utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx bytecomp/dll.cmx \
- utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \
- utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \
- bytecomp/bytelink.cmi
+ bytecomp/covutils.cmx utils/consistbl.cmx utils/config.cmx \
+ bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \
+ bytecomp/bytesections.cmx bytecomp/bytelink.cmi
bytecomp/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \
typing/subst.cmi typing/path.cmi utils/misc.cmi bytecomp/instruct.cmi \
typing/ident.cmi typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \
@@ -352,28 +359,42 @@
bytecomp/bytegen.cmx bytecomp/bytepackager.cmi
bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi
bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi
+bytecomp/covutils.cmo: typing/types.cmi bytecomp/typeopt.cmi \
+ typing/typedtree.cmi typing/primitive.cmi typing/predef.cmi \
+ typing/path.cmi utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi \
+ bytecomp/instruct.cmi typing/ident.cmi bytecomp/covevent.cmi \
+ bytecomp/cmo_format.cmi parsing/asttypes.cmi bytecomp/covutils.cmi
+bytecomp/covutils.cmx: typing/types.cmx bytecomp/typeopt.cmx \
+ typing/typedtree.cmx typing/primitive.cmx typing/predef.cmx \
+ typing/path.cmx utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx \
+ bytecomp/instruct.cmx typing/ident.cmx bytecomp/covevent.cmi \
+ bytecomp/cmo_format.cmi parsing/asttypes.cmi bytecomp/covutils.cmi
bytecomp/dll.cmo: utils/misc.cmi utils/config.cmi bytecomp/dll.cmi
bytecomp/dll.cmx: utils/misc.cmx utils/config.cmx bytecomp/dll.cmi
bytecomp/emitcode.cmo: bytecomp/translmod.cmi typing/primitive.cmi \
bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \
- bytecomp/instruct.cmi typing/env.cmi utils/config.cmi \
- bytecomp/cmo_format.cmi utils/clflags.cmi typing/btype.cmi \
- parsing/asttypes.cmi bytecomp/emitcode.cmi
+ bytecomp/instruct.cmi typing/env.cmi bytecomp/covutils.cmi \
+ bytecomp/covevent.cmi utils/config.cmi bytecomp/cmo_format.cmi \
+ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
+ bytecomp/emitcode.cmi
bytecomp/emitcode.cmx: bytecomp/translmod.cmx typing/primitive.cmx \
bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \
- bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \
- bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \
- parsing/asttypes.cmi bytecomp/emitcode.cmi
+ bytecomp/instruct.cmx typing/env.cmx bytecomp/covutils.cmx \
+ bytecomp/covevent.cmi utils/config.cmx bytecomp/cmo_format.cmi \
+ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+ bytecomp/emitcode.cmi
bytecomp/instruct.cmo: typing/types.cmi typing/subst.cmi parsing/location.cmi \
- bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/instruct.cmi
+ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/covevent.cmi \
+ bytecomp/instruct.cmi
bytecomp/instruct.cmx: typing/types.cmx typing/subst.cmx parsing/location.cmx \
- bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx bytecomp/instruct.cmi
+ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx bytecomp/covevent.cmi \
+ bytecomp/instruct.cmi
bytecomp/lambda.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \
utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \
- parsing/asttypes.cmi bytecomp/lambda.cmi
+ bytecomp/covevent.cmi parsing/asttypes.cmi bytecomp/lambda.cmi
bytecomp/lambda.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \
utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
- parsing/asttypes.cmi bytecomp/lambda.cmi
+ bytecomp/covevent.cmi parsing/asttypes.cmi bytecomp/lambda.cmi
bytecomp/matching.cmo: typing/types.cmi bytecomp/typeopt.cmi \
typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
typing/primitive.cmi typing/predef.cmi typing/path.cmi \
@@ -394,16 +415,16 @@
bytecomp/opcodes.cmx:
bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \
bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \
- bytecomp/printinstr.cmi
+ bytecomp/covutils.cmi bytecomp/printinstr.cmi
bytecomp/printinstr.cmx: bytecomp/printlambda.cmx parsing/location.cmx \
bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \
- bytecomp/printinstr.cmi
+ bytecomp/covutils.cmx bytecomp/printinstr.cmi
bytecomp/printlambda.cmo: typing/types.cmi typing/primitive.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
- parsing/asttypes.cmi bytecomp/printlambda.cmi
+ bytecomp/covutils.cmi parsing/asttypes.cmi bytecomp/printlambda.cmi
bytecomp/printlambda.cmx: typing/types.cmx typing/primitive.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
- parsing/asttypes.cmi bytecomp/printlambda.cmi
+ bytecomp/covutils.cmx parsing/asttypes.cmi bytecomp/printlambda.cmi
bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi
bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi
bytecomp/simplif.cmo: bytecomp/lambda.cmi typing/ident.cmi utils/clflags.cmi \
@@ -436,14 +457,16 @@
typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \
typing/predef.cmi typing/path.cmi typing/parmatch.cmi utils/misc.cmi \
bytecomp/matching.cmi parsing/location.cmi bytecomp/lambda.cmi \
- typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \
- typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi
+ typing/ident.cmi typing/env.cmi bytecomp/covutils.cmi \
+ bytecomp/covevent.cmi utils/config.cmi utils/clflags.cmi typing/btype.cmi \
+ parsing/asttypes.cmi bytecomp/translcore.cmi
bytecomp/translcore.cmx: typing/types.cmx bytecomp/typeopt.cmx \
typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \
typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \
bytecomp/matching.cmx parsing/location.cmx bytecomp/lambda.cmx \
- typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
- typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi
+ typing/ident.cmx typing/env.cmx bytecomp/covutils.cmx \
+ bytecomp/covevent.cmi utils/config.cmx utils/clflags.cmx typing/btype.cmx \
+ parsing/asttypes.cmi bytecomp/translcore.cmi
bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \
bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
@@ -479,9 +502,9 @@
asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi parsing/asttypes.cmi
asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi
-asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.cmi
asmcomp/cmmgen.cmi: asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
asmcomp/clambda.cmi
+asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.cmi
asmcomp/cmx_format.cmi: asmcomp/clambda.cmi
asmcomp/codegen.cmi: asmcomp/cmm.cmi
asmcomp/coloring.cmi:
@@ -489,8 +512,8 @@
asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/cmx_format.cmi \
asmcomp/clambda.cmi
asmcomp/debuginfo.cmi: parsing/location.cmi bytecomp/lambda.cmi
-asmcomp/emit.cmi: asmcomp/linearize.cmi asmcomp/cmm.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/debuginfo.cmi
asmcomp/liveness.cmi: asmcomp/mach.cmi
@@ -501,8 +524,8 @@
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 \
@@ -572,10 +595,6 @@
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/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/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
@@ -588,6 +607,10 @@
asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \
asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
asmcomp/cmmgen.cmi
+asmcomp/cmm.cmo: 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 \
@@ -614,6 +637,12 @@
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 asmcomp/linearize.cmi asmcomp/emitaux.cmi \
asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
@@ -622,12 +651,6 @@
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/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/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 \
@@ -668,14 +691,14 @@
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/reg.cmi asmcomp/mach.cmi \
- asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi
-asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
- asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.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 utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi
+asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
+ asmcomp/cmm.cmx utils/clflags.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
@@ -706,8 +729,8 @@
asmcomp/split.cmi
driver/compile.cmi: typing/env.cmi
driver/errors.cmi:
-driver/main.cmi:
driver/main_args.cmi:
+driver/main.cmi:
driver/optcompile.cmi: typing/env.cmi
driver/opterrors.cmi:
driver/optmain.cmi:
@@ -740,6 +763,8 @@
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: utils/warnings.cmi driver/main_args.cmi
+driver/main_args.cmx: utils/warnings.cmx driver/main_args.cmi
driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmi \
bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
@@ -748,8 +773,6 @@
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: utils/warnings.cmi driver/main_args.cmi
-driver/main_args.cmx: utils/warnings.cmx driver/main_args.cmi
driver/optcompile.cmo: utils/warnings.cmi typing/unused_var.cmi \
typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \
typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
diff -urN ocaml-3.12.0/Makefile ocaml-diff/Makefile
--- ocaml-3.12.0/Makefile 2010-06-16 03:32:26.000000000 +0200
+++ ocaml-diff/Makefile 2012-03-14 14:42:30.000000000 +0100
@@ -17,15 +17,15 @@
include config/Makefile
include stdlib/StdlibModules
-CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
+CAMLC=@OCAMLPREFIX@/bin/ocamlc
CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
COMPFLAGS=-strict-sequence -warn-error A $(INCLUDES)
LINKFLAGS=
-CAMLYACC=boot/ocamlyacc
+CAMLYACC=@OCAMLPREFIX@/bin/ocamlyacc
YACCFLAGS=-v
-CAMLLEX=boot/ocamlrun boot/ocamllex
-CAMLDEP=boot/ocamlrun tools/ocamldep
+CAMLLEX=@OCAMLPREFIX@/bin/ocamllex
+CAMLDEP=@OCAMLPREFIX@/bin/ocamldep
DEPFLAGS=$(INCLUDES)
CAMLRUN=byterun/ocamlrun
SHELL=/bin/sh
@@ -57,7 +57,7 @@
typing/typedecl.cmo typing/typeclass.cmo \
typing/typemod.cmo
-COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
+COMP=bytecomp/lambda.cmo bytecomp/covutils.cmo bytecomp/printlambda.cmo \
bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
bytecomp/translobj.cmo bytecomp/translcore.cmo \
bytecomp/translclass.cmo bytecomp/translmod.cmo \
Binary files ocaml-3.12.0/bytecomp/.DS_Store and ocaml-diff/bytecomp/.DS_Store differ
diff -urN ocaml-3.12.0/bytecomp/bytegen.ml ocaml-diff/bytecomp/bytegen.ml
--- ocaml-3.12.0/bytecomp/bytegen.ml 2009-05-20 13:52:42.000000000 +0200
+++ ocaml-diff/bytecomp/bytegen.ml 2012-03-14 14:42:30.000000000 +0100
@@ -159,6 +159,7 @@
| Lprim (Pduprecord (Record_regular, size), args) -> RHS_block size
| Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size
| Levent (lam, _) -> size_of_lambda lam
+ | Lcovevent (lam, _) -> size_of_lambda lam
| Lsequence (lam, lam') -> size_of_lambda lam'
| _ -> RHS_nonrec
@@ -754,6 +755,8 @@
let cont1 = add_event ev cont in
comp_expr env lam sz cont1
end
+ | Lcovevent (lam, lco) ->
+ Covutils.comp_expr comp_expr env lam sz cont !compunit_name lco
| Lifused (_, exp) ->
comp_expr env exp sz cont
diff -urN ocaml-3.12.0/bytecomp/bytelink.ml ocaml-diff/bytecomp/bytelink.ml
--- ocaml-3.12.0/bytecomp/bytelink.ml 2010-01-20 17:26:46.000000000 +0100
+++ ocaml-diff/bytecomp/bytelink.ml 2012-03-14 14:42:30.000000000 +0100
@@ -194,6 +194,7 @@
really_input inchan buffer 0 compunit.cu_debugsize;
debug_info := (currpos_fun(), buffer) :: !debug_info
end;
+ Covutils.link_compunit currpos_fun compunit;
output_fun code_block;
if !Clflags.link_everything then
List.iter Symtable.require_primitive compunit.cu_primitives
@@ -303,7 +304,9 @@
end;
let output_fun = output_string outchan
and currpos_fun () = pos_out outchan - start_code in
+ Covutils.cov_info_output := open_out "cover.info";
List.iter (link_file output_fun currpos_fun) tolink;
+ close_out !Covutils.cov_info_output;
if standalone then Dll.close_all_dlls();
(* The final STOP instruction *)
output_byte outchan Opcodes.opSTOP;
@@ -424,7 +427,9 @@
output_code_string outchan code;
currpos := !currpos + String.length code
and currpos_fun () = !currpos in
+ Covutils.cov_info_output := open_out "cover.info";
List.iter (link_file output_fun currpos_fun) tolink;
+ close_out !Covutils.cov_info_output;
(* The final STOP instruction *)
Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP;
(* The table of global data *)
diff -urN ocaml-3.12.0/bytecomp/covevent.mli ocaml-diff/bytecomp/covevent.mli
--- ocaml-3.12.0/bytecomp/covevent.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-diff/bytecomp/covevent.mli 2012-08-29 19:43:16.000000000 +0200
@@ -0,0 +1,28 @@
+(***********************************************************************)
+(* Project Couverture *)
+(* *)
+(* file: covevent.mli *)
+(* authors: Adrien Jonquet, Mathias Bourgoin *)
+(* licence: CeCILL-B *)
+(***********************************************************************)
+
+type coverage_event =
+ { mutable covev_pos: int;
+ covev_module: string;
+ covev_loc: Location.t;
+ covev_status: coverage_event_status }
+
+and coverage_event_status =
+ Coverage_event_statement
+ | Coverage_event_decision
+ | Coverage_event_condition of coverage_event
+ (* [coverage_event] refers to the decision the condition belongs to. *)
+
+type lambda =
+ { lcovev_loc: Location.t;
+ lcovev_status: lambda_status }
+
+and lambda_status =
+ Lcovev_statement
+ | Lcovev_decision
+ | Lcovev_condition of lambda (* [lambda] refers to the decision the condition belongs to. *)
diff -urN ocaml-3.12.0/bytecomp/covutils.ml ocaml-diff/bytecomp/covutils.ml
--- ocaml-3.12.0/bytecomp/covutils.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-diff/bytecomp/covutils.ml 2012-09-06 18:05:26.000000000 +0200
@@ -0,0 +1,196 @@
+(***********************************************************************)
+(* Project Couverture *)
+(* *)
+(* file: covutils.ml *)
+(* authors: Adrien Jonquet, Mathias Bourgoin, Philippe Wang *)
+(* licence: CeCILL-B *)
+(***********************************************************************)
+
+open Misc
+open Asttypes
+open Primitive
+open Path
+open Types
+open Typedtree
+open Typeopt
+open Lambda
+(* open Covevent *)
+
+let rec is_bool = function
+ Tconstr ((Pident i) as path, _, _) -> path = Predef.path_bool
+ | Tconstr (_, _, _) -> false
+ | Tpoly (_, _) -> false
+ | Tvariant _ -> false
+ | Tsubst te -> is_bool te.desc
+ | Tlink te -> is_bool te.desc
+ | Tfield (_, _, _, _) -> false
+ | Tobject (_, _) -> false
+ | Ttuple _ -> false
+ | Tarrow (_, _, _, _) -> false
+ | Tunivar -> false
+ | Tnil -> false
+ | Tvar -> false
+ | Tpackage _ -> false
+
+(* Insertion of coverage events *)
+let put exp status lam =
+ Lcovevent(lam, { Covevent.lcovev_loc = exp.exp_loc;
+ lcovev_status = status })
+
+let build_lambda_covev exp status =
+ { Covevent.lcovev_loc = exp.exp_loc;
+ lcovev_status = status }
+
+let add_coverage_event event cont = Instruct.Kcovevent event :: cont
+
+(* Bytegen *)
+
+let comp_expr
+ (continuation:('a -> 'b -> 'c -> Instruct.instruction list -> Instruct.instruction list))
+ (env:'a)
+ (lam:'b)
+ (sz:'c)
+ (cont:Instruct.instruction list)
+ (compunit_name:string)
+ (lco:Covevent.lambda)
+ : Instruct.instruction list
+ =
+ let event status = {
+ Covevent.covev_pos = 0; (* patched in emitcode *)
+ Covevent.covev_module = compunit_name;
+ Covevent.covev_loc = lco.Covevent.lcovev_loc;
+ Covevent.covev_status = status
+ } in
+ let s = match lco.Covevent.lcovev_status with
+ Covevent.Lcovev_statement -> Covevent.Coverage_event_statement
+ | Covevent.Lcovev_decision -> Covevent.Coverage_event_decision
+ | Covevent.Lcovev_condition lcovev ->
+ let rec covev_of_lcovev lcov =
+ let status = match lcov.Covevent.lcovev_status with
+ Covevent.Lcovev_statement -> Covevent.Coverage_event_statement
+ | Covevent.Lcovev_decision -> Covevent.Coverage_event_decision
+ | Covevent.Lcovev_condition lcov2 -> Covevent.Coverage_event_condition (covev_of_lcovev lcov2) in
+ { Covevent.covev_pos = (-1);
+ Covevent.covev_module = compunit_name;
+ Covevent.covev_loc = lcov.Covevent.lcovev_loc;
+ Covevent.covev_status = status } in
+ Covevent.Coverage_event_condition (covev_of_lcovev lcovev) in
+ let ev = event s in
+ let cont1 = add_coverage_event ev cont in
+ continuation env lam sz cont1
+
+(* Bytelink *)
+
+let cov_info_output = ref stdout
+
+let link_compunit currpos_fun compunit =
+ if Sys.file_exists (compunit.Cmo_format.cu_name ^ ".cmo.covermo") then begin
+ let ci = open_in (compunit.Cmo_format.cu_name ^ ".cmo.covermo") in
+ let ev_list = Marshal.from_channel ci in
+ Sys.remove (compunit.Cmo_format.cu_name ^ ".cmo.covermo");
+ let co = open_out (compunit.Cmo_format.cu_name ^ ".cmo.cover") in
+ output_value co (currpos_fun(), ev_list);
+ output_string !cov_info_output compunit.Cmo_format.cu_name;
+ output_string !cov_info_output "\n";
+ close_out co;
+ close_in ci
+ end
+
+(* Emitcode *)
+
+let coverage_events = ref ([] : Covevent.coverage_event list)
+
+let record_covevent covevent out_position =
+ covevent.Covevent.covev_pos <- !out_position;
+ coverage_events := covevent :: !coverage_events
+
+let to_file unit_name =
+ let coverage_chan = open_out (unit_name ^ ".cmo.covermo") in
+ output_value coverage_chan !coverage_events;
+ close_out coverage_chan
+
+(* Translcore *)
+
+let with_from_dec dec f arg =
+ f dec arg
+
+let with_new_dec f arg = with_from_dec None f arg
+
+let covevent_of_exp dec e =
+ (* >semantics< *)
+ if is_bool e.exp_type.desc then
+ match dec with
+ Some d -> Covevent.Lcovev_condition d
+ | None -> Covevent.Lcovev_decision
+ else Covevent.Lcovev_statement
+
+let is_bool_prim p =
+ (p.prim_name = "%sequor") || (p.prim_name = "%sequand") || (p.prim_name = "%boolnot")
+
+(* let apply_prim_put_dec (dec:'a option) e p f arg = *)
+(* (\* >semantics< *\) *)
+(* if is_bool_prim p then *)
+(* if dec = None then *)
+(* let dec = Some (build_lambda_covev e Covevent.Lcovev_decision) in *)
+(* with_from_dec dec f arg *)
+(* else f dec arg *)
+(* else *)
+(* begin *)
+(* if is_bool e.exp_type.desc && dec <> None then *)
+(* with_new_dec f arg *)
+(* else f dec arg *)
+(* end *)
+
+let apply_prim_put_dec (dec:'a option) e p f (args:Typedtree.expression list) =
+ (* >semantics< *)
+ if is_bool e.exp_type.desc && dec = None then
+ with_new_dec f args
+ else
+ with_from_dec dec f args
+
+(* (\* *)
+(* let _old_apply_prim_covev p e = *)
+(* (\* >semantics< *\) *)
+(* if is_bool e.exp_type.desc then (\* a Boolean *\) *)
+(* if is_bool_prim p then *)
+(* begin *)
+(* if !from_dec = None then Covevent.Lcovev_decision *)
+(* else Covevent.Lcovev_statement *)
+(* end *)
+(* else *)
+(* begin *)
+(* match !from_dec with *)
+(* | None -> Covevent.Lcovev_decision *)
+(* | Some dec -> Covevent.Lcovev_condition dec *)
+(* end *)
+(* else (\* not a Boolean *\) *)
+(* Covevent.Lcovev_statement *)
+(* *\) *)
+
+let apply_prim_covev dec p e =
+ (* >semantics< *)
+ if is_bool e.exp_type.desc then (* a Boolean *)
+ begin
+ match dec with
+ | None -> Covevent.Lcovev_decision
+ | Some dec -> Covevent.Lcovev_condition dec
+ end
+ else (* not a Boolean *)
+ Covevent.Lcovev_statement
+
+
+(* Printinstr *)
+
+let print_instruction ppf event =
+ Format.fprintf ppf "\tcovevent_event \"%s\" %i-%i"
+ event.Covevent.covev_loc.Location.loc_start.Lexing.pos_fname
+ event.Covevent.covev_loc.Location.loc_start.Lexing.pos_cnum
+ event.Covevent.covev_loc.Location.loc_end.Lexing.pos_cnum
+
+(* Printlambda *)
+
+let print_lambda ppf lam expr ev =
+ Format.fprintf ppf "@[<2>(%i-%i@ %a)@]"
+ ev.Covevent.lcovev_loc.Location.loc_start.Lexing.pos_cnum
+ ev.Covevent.lcovev_loc.Location.loc_end.Lexing.pos_cnum
+ lam expr
diff -urN ocaml-3.12.0/bytecomp/covutils.mli ocaml-diff/bytecomp/covutils.mli
--- ocaml-3.12.0/bytecomp/covutils.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-diff/bytecomp/covutils.mli 2012-09-03 02:31:07.000000000 +0200
@@ -0,0 +1,53 @@
+(***********************************************************************)
+(* Project Couverture *)
+(* *)
+(* file: covutils.mli *)
+(* authors: Adrien Jonquet, Mathias Bourgoin *)
+(* licence: CeCILL-B *)
+(***********************************************************************)
+
+val is_bool : Types.type_desc -> bool
+
+val put : (Typedtree.expression -> Covevent.lambda_status -> Lambda.lambda -> Lambda.lambda)
+
+val build_lambda_covev : Typedtree.expression -> Covevent.lambda_status -> Covevent.lambda
+
+val comp_expr :
+ ('a -> 'b -> 'c -> Instruct.instruction list -> Instruct.instruction list) ->
+ 'a ->
+ 'b ->
+ 'c ->
+ Instruct.instruction list ->
+ string -> Covevent.lambda -> Instruct.instruction list
+
+val cov_info_output : out_channel ref
+
+val link_compunit : (unit -> 'a) -> Cmo_format.compilation_unit -> unit
+
+val coverage_events : Covevent.coverage_event list ref
+
+val record_covevent : Covevent.coverage_event -> int ref -> unit
+
+val to_file : string -> unit
+
+val with_new_dec : ('dec option -> 'a -> 'b) -> 'a -> 'b
+
+val covevent_of_exp : Covevent.lambda option -> Typedtree.expression -> Covevent.lambda_status
+
+val apply_prim_put_dec :
+ 'a option ->
+ Typedtree.expression ->
+ 'b ->
+ ('a option -> Typedtree.expression list -> 'c) ->
+ Typedtree.expression list -> 'c
+ (* Typedtree.expression -> Primitive.description -> ('a -> 'b) -> 'a -> 'b *)
+
+val apply_prim_covev :
+ Covevent.lambda option -> 'a -> Typedtree.expression -> Covevent.lambda_status
+
+(* 'dec option -> Primitive.description -> Typedtree.expression -> Covevent.lambda_status *)
+
+val print_instruction : Format.formatter -> Covevent.coverage_event -> unit
+
+val print_lambda :
+ Format.formatter -> (Format.formatter -> 'a -> unit) -> 'a -> Covevent.lambda -> unit
diff -urN ocaml-3.12.0/bytecomp/emitcode.ml ocaml-diff/bytecomp/emitcode.ml
--- ocaml-3.12.0/bytecomp/emitcode.ml 2010-01-22 13:48:24.000000000 +0100
+++ ocaml-diff/bytecomp/emitcode.ml 2012-03-14 14:42:30.000000000 +0100
@@ -148,6 +148,7 @@
out_position := 0;
label_table := Array.create 16 (Label_undefined []);
reloc_info := [];
+ Covutils.coverage_events := [];
events := []
(* Emission of one instruction *)
@@ -266,6 +267,7 @@
| Kgetpubmet tag -> out opGETPUBMET; out_int tag; out_int 0
| Kgetdynmet -> out opGETDYNMET
| Kevent ev -> record_event ev
+ | Kcovevent covev -> Covutils.record_covevent covev out_position
| Kstop -> out opSTOP
(* Emission of a list of instructions. Include some peephole optimization. *)
@@ -344,6 +346,12 @@
| Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
(Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c ->
emit (Kpush :: instr :: ev :: c)
+ | Kpush :: (Kcovevent _ as ev) ::
+ (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c ->
+ emit (Kpush :: instr1 :: instr2 :: ev :: c)
+ | Kpush :: (Kcovevent _ as ev) ::
+ (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c ->
+ emit (Kpush :: instr :: ev :: c)
| Kgetglobal id :: Kgetfield n :: c ->
out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
(* Default case *)
@@ -367,6 +375,7 @@
(p, pos_out outchan - p)
end else
(0, 0) in
+ Covutils.to_file unit_name;
let compunit =
{ cu_name = unit_name;
cu_pos = pos_code;
diff -urN ocaml-3.12.0/bytecomp/instruct.ml ocaml-diff/bytecomp/instruct.ml
--- ocaml-3.12.0/bytecomp/instruct.ml 2009-05-20 13:52:42.000000000 +0200
+++ ocaml-diff/bytecomp/instruct.ml 2012-03-14 14:42:30.000000000 +0100
@@ -101,6 +101,7 @@
| Kgetpubmet of int
| Kgetdynmet
| Kevent of debug_event
+ | Kcovevent of Covevent.coverage_event
| Kstop
let immed_min = -0x40000000
diff -urN ocaml-3.12.0/bytecomp/instruct.mli ocaml-diff/bytecomp/instruct.mli
--- ocaml-3.12.0/bytecomp/instruct.mli 2009-05-20 13:52:42.000000000 +0200
+++ ocaml-diff/bytecomp/instruct.mli 2012-03-14 14:42:30.000000000 +0100
@@ -121,6 +121,7 @@
| Kgetpubmet of int
| Kgetdynmet
| Kevent of debug_event
+ | Kcovevent of Covevent.coverage_event
| Kstop
val immed_min: int
diff -urN ocaml-3.12.0/bytecomp/lambda.ml ocaml-diff/bytecomp/lambda.ml
--- ocaml-3.12.0/bytecomp/lambda.ml 2010-01-22 13:48:24.000000000 +0100
+++ ocaml-diff/bytecomp/lambda.ml 2012-03-14 14:42:30.000000000 +0100
@@ -142,6 +142,7 @@
| Lassign of Ident.t * lambda
| Lsend of meth_kind * lambda * lambda * lambda list
| Levent of lambda * lambda_event
+ | Lcovevent of lambda * Covevent.lambda
| Lifused of Ident.t * lambda
and lambda_switch =
@@ -205,6 +206,8 @@
k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
| Levent(a1, ev1), Levent(a2, ev2) ->
same a1 a2 && ev1.lev_loc = ev2.lev_loc
+ | Lcovevent(a1, ev1), Lcovevent(a2, ev2) ->
+ same a1 a2 && ev1.Covevent.lcovev_loc = ev2.Covevent.lcovev_loc
| Lifused(id1, a1), Lifused(id2, a2) ->
Ident.same id1 id2 && same a1 a2
| _, _ ->
@@ -281,6 +284,8 @@
List.iter f (met::obj::args)
| Levent (lam, evt) ->
f lam
+ | Lcovevent (lam, evt) ->
+ f lam
| Lifused (v, e) ->
f e
@@ -313,7 +318,7 @@
| Lvar _ | Lconst _ | Lapply _
| Lprim _ | Lswitch _ | Lstaticraise _
| Lifthenelse _ | Lsequence _ | Lwhile _
- | Lsend _ | Levent _ | Lifused _ -> ()
+ | Lsend _ | Levent _ | Lcovevent _ | Lifused _ -> ()
in free l; !fv
let free_variables l =
@@ -336,6 +341,7 @@
| Lifthenelse( cond, body, Lstaticraise (0,[])) -> true
| Llet(str, id, lam, body) -> is_guarded body
| Levent(lam, ev) -> is_guarded lam
+ | Lcovevent(lam, ev) -> is_guarded lam
| _ -> false
let rec patch_guarded patch = function
@@ -345,6 +351,8 @@
Llet (str, id, lam, patch_guarded patch body)
| Levent(lam, ev) ->
Levent (patch_guarded patch lam, ev)
+ | Lcovevent(lam, ev) ->
+ Lcovevent (patch_guarded patch lam, ev)
| _ -> fatal_error "Lambda.patch_guarded"
(* Translate an access path *)
@@ -401,6 +409,7 @@
| Lsend (k, met, obj, args) ->
Lsend (k, subst met, subst obj, List.map subst args)
| Levent (lam, evt) -> Levent (subst lam, evt)
+ | Lcovevent (lam, evt) -> Lcovevent (subst lam, evt)
| Lifused (v, e) -> Lifused (v, subst e)
and subst_decl (id, exp) = (id, subst exp)
and subst_case (key, case) = (key, subst case)
diff -urN ocaml-3.12.0/bytecomp/lambda.mli ocaml-diff/bytecomp/lambda.mli
--- ocaml-3.12.0/bytecomp/lambda.mli 2010-04-18 11:02:40.000000000 +0200
+++ ocaml-diff/bytecomp/lambda.mli 2012-03-14 14:42:30.000000000 +0100
@@ -151,6 +151,7 @@
| Lassign of Ident.t * lambda
| Lsend of meth_kind * lambda * lambda * lambda list
| Levent of lambda * lambda_event
+ | Lcovevent of lambda * Covevent.lambda
| Lifused of Ident.t * lambda
and lambda_switch =
diff -urN ocaml-3.12.0/bytecomp/printinstr.ml ocaml-diff/bytecomp/printinstr.ml
--- ocaml-3.12.0/bytecomp/printinstr.ml 2005-08-25 17:35:16.000000000 +0200
+++ ocaml-diff/bytecomp/printinstr.ml 2012-03-14 14:42:30.000000000 +0100
@@ -103,6 +103,7 @@
ev.ev_loc.Location.loc_start.Lexing.pos_fname
ev.ev_loc.Location.loc_start.Lexing.pos_cnum
ev.ev_loc.Location.loc_end.Lexing.pos_cnum
+ | Kcovevent ev -> Covutils.print_instruction ppf ev
let rec instruction_list ppf = function
[] -> ()
diff -urN ocaml-3.12.0/bytecomp/printlambda.ml ocaml-diff/bytecomp/printlambda.ml
--- ocaml-3.12.0/bytecomp/printlambda.ml 2008-08-01 18:57:10.000000000 +0200
+++ ocaml-diff/bytecomp/printlambda.ml 2012-03-14 14:42:30.000000000 +0100
@@ -301,6 +301,8 @@
ev.lev_loc.Location.loc_start.Lexing.pos_cnum
ev.lev_loc.Location.loc_end.Lexing.pos_cnum
lam expr
+ | Lcovevent(expr, ev) ->
+ Covutils.print_lambda ppf lam expr ev
| Lifused(id, expr) ->
fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr
diff -urN ocaml-3.12.0/bytecomp/simplif.ml ocaml-diff/bytecomp/simplif.ml
--- ocaml-3.12.0/bytecomp/simplif.ml 2010-01-22 13:48:24.000000000 +0100
+++ ocaml-diff/bytecomp/simplif.ml 2012-03-14 14:42:30.000000000 +0100
@@ -80,6 +80,8 @@
List.map (eliminate_ref id) el)
| Levent(l, ev) ->
Levent(eliminate_ref id l, ev)
+ | Lcovevent(l, ev) ->
+ Lcovevent(eliminate_ref id l, ev)
| Lifused(v, e) ->
Lifused(v, eliminate_ref id e)
@@ -146,6 +148,7 @@
count l
| Lsend(k, m, o, ll) -> List.iter count (m::o::ll)
| Levent(l, _) -> count l
+ | Lcovevent(l, _) -> count l
| Lifused(v, l) -> count l
and count_default sw = match sw.sw_failaction with
@@ -252,6 +255,7 @@
| Lassign(v, l) -> Lassign(v, simplif l)
| Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
| Levent(l, ev) -> Levent(simplif l, ev)
+ | Lcovevent(l, ev) -> Lcovevent(simplif l, ev)
| Lifused(v, l) -> Lifused (v,simplif l)
in
simplif lam
@@ -315,6 +319,7 @@
count l
| Lsend(_, m, o, ll) -> List.iter count (m::o::ll)
| Levent(l, _) -> count l
+ | Lcovevent(l, _) -> count l
| Lifused(v, l) ->
if count_var v > 0 then count l
@@ -404,6 +409,7 @@
| Lassign(v, l) -> Lassign(v, simplif l)
| Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
| Levent(l, ev) -> Levent(simplif l, ev)
+ | Lcovevent(l, ev) -> Lcovevent(simplif l, ev)
| Lifused(v, l) ->
if count_var v > 0 then simplif l else lambda_unit
in
diff -urN ocaml-3.12.0/bytecomp/translcore.ml ocaml-diff/bytecomp/translcore.ml
--- ocaml-3.12.0/bytecomp/translcore.ml 2010-05-20 16:57:42.000000000 +0200
+++ ocaml-diff/bytecomp/translcore.ml 2012-09-07 02:24:03.000000000 +0200
@@ -384,6 +384,7 @@
| Lprim (Pmakearray (Pgenarray), args) -> false
| Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2
| Levent (lam, _) -> check_top idlist lam
+ | Lcovevent (lam, _) -> check_top idlist lam
| lam -> check idlist lam
and check idlist = function
@@ -403,6 +404,7 @@
List.for_all (check idlist) args
| Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2
| Levent (lam, _) -> check idlist lam
+ | Lcovevent (lam, _) -> check idlist lam
| lam ->
let fv = free_variables lam in
not (List.exists (fun id -> IdentSet.mem id fv) idlist)
@@ -554,311 +556,399 @@
(* Translation of expressions *)
-let rec transl_exp e =
+let rec transl_exp (dec:'a option) (e:Typedtree.expression) : Lambda.lambda =
let eval_once =
(* Whether classes for immediate objects must be cached *)
match e.exp_desc with
- Texp_function _ | Texp_for _ | Texp_while _ -> false
- | _ -> true
+ Texp_function _ | Texp_for _ | Texp_while _ -> false
+ | _ -> true
in
- if eval_once then transl_exp0 e else
- Translobj.oo_wrap e.exp_env true transl_exp0 e
+ if eval_once then transl_exp0 dec e else
+ Translobj.oo_wrap e.exp_env true (transl_exp0 dec) e
-and transl_exp0 e =
+and transl_exp0 (dec:'a option) (e:Typedtree.expression) : Lambda.lambda =
match e.exp_desc with
- Texp_ident(path, {val_kind = Val_prim p}) ->
- let public_send = p.prim_name = "%send" in
- if public_send || p.prim_name = "%sendself" then
- let kind = if public_send then Public else Self in
- let obj = Ident.create "obj" and meth = Ident.create "meth" in
- Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, []))
- else if p.prim_name = "%sendcache" then
- let obj = Ident.create "obj" and meth = Ident.create "meth" in
- let cache = Ident.create "cache" and pos = Ident.create "pos" in
- Lfunction(Curried, [obj; meth; cache; pos],
- Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos]))
- else
- transl_primitive p
- | Texp_ident(path, {val_kind = Val_anc _}) ->
- raise(Error(e.exp_loc, Free_super_var))
- | Texp_ident(path, {val_kind = Val_reg | Val_self _}) ->
- transl_path path
- | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
- | Texp_constant cst ->
- Lconst(Const_base cst)
- | Texp_let(rec_flag, pat_expr_list, body) ->
- transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
- | Texp_function (pat_expr_list, partial) ->
- let ((kind, params), body) =
- event_function e
- (function repr ->
- let pl = push_defaults e.exp_loc [] pat_expr_list partial in
- transl_function e.exp_loc !Clflags.native_code repr partial pl)
- in
- Lfunction(kind, params, body)
- | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, oargs)
- when List.length oargs >= p.prim_arity
- && List.for_all (fun (arg,_) -> arg <> None) oargs ->
- let args, args' = cut p.prim_arity oargs in
- let wrap f =
- if args' = []
- then event_after e f
- else event_after e (transl_apply f args' e.exp_loc)
- in
- let wrap0 f =
- if args' = [] then f else wrap f in
- let args = List.map (function Some x, _ -> x | _ -> assert false) args in
- let argl = transl_list args in
- let public_send = p.prim_name = "%send"
- || not !Clflags.native_code && p.prim_name = "%sendcache"in
- if public_send || p.prim_name = "%sendself" then
- let kind = if public_send then Public else Self in
- let obj = List.hd argl in
- wrap (Lsend (kind, List.nth argl 1, obj, []))
- else if p.prim_name = "%sendcache" then
- match argl with [obj; meth; cache; pos] ->
- wrap (Lsend(Cached, meth, obj, [cache; pos]))
- | _ -> assert false
- else begin
- let prim = transl_prim p args in
- match (prim, args) with
- (Praise, [arg1]) ->
- wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
- | (_, _) ->
- begin match (prim, argl) with
- | (Plazyforce, [a]) ->
- wrap (Matching.inline_lazy_force a e.exp_loc)
- | (Plazyforce, _) -> assert false
- |_ -> let p = Lprim(prim, argl) in
- if primitive_is_ccall prim then wrap p else wrap0 p
+ Texp_ident(path, {val_kind = Val_prim p}) ->
+ let public_send = p.prim_name = "%send" in
+ if public_send || p.prim_name = "%sendself" then
+ let kind = if public_send then Public else Self in
+ let obj = Ident.create "obj" and meth = Ident.create "meth" in
+ Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, []))
+ else if p.prim_name = "%sendcache" then
+ let obj = Ident.create "obj" and meth = Ident.create "meth" in
+ let cache = Ident.create "cache" and pos = Ident.create "pos" in
+ (Lfunction(Curried, [obj; meth; cache; pos],
+ Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos])))
+ else
+ transl_primitive p
+ | Texp_ident(path, {val_kind = Val_anc _}) ->
+ raise(Error(e.exp_loc, Free_super_var))
+ | Texp_ident(path, {val_kind = Val_reg | Val_self _}) ->
+ Covutils.put e (Covutils.covevent_of_exp dec e) (transl_path path)
+ | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
+ | Texp_constant cst ->
+ Covutils.put e Covevent.Lcovev_statement (Lconst(Const_base cst))
+ | Texp_let(rec_flag, pat_expr_list, body) ->
+ (* dec transmission for let bodies except for functions *)
+ if pat_expr_list = [] then
+ transl_let dec rec_flag pat_expr_list (event_before body (transl_exp dec body))
+ else
+ transl_let None rec_flag pat_expr_list (event_before body (transl_exp None body))
+ | Texp_function (pat_expr_list, partial) ->
+ (* no dec transmission to functions *)
+ let ((kind, params), body) =
+ event_function e
+ (function repr ->
+ let pl = push_defaults e.exp_loc [] pat_expr_list partial in
+ transl_function None e.exp_loc !Clflags.native_code repr partial pl)
+ in
+ Lfunction(kind, params, body)
+
+ (* ****************************** APPLY (PRIMITIVE) *******************************)
+ | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, oargs)
+ when List.length oargs >= p.prim_arity
+ && List.for_all (fun (arg,_) -> arg <> None) oargs
+ ->
+ let args, args' = cut p.prim_arity oargs in
+ let wrap f =
+ if args' = []
+ then event_after e f
+ else event_after e (transl_apply dec f args' e.exp_loc)
+ in
+ let wrap0 f =
+ if args' = [] then f else wrap f in
+ let args : Typedtree.expression list =
+ List.map (function Some x, _ -> x | _ -> assert false) args in
+ let argl : Lambda.lambda list =
+ Covutils.apply_prim_put_dec
+ (dec:Covevent.lambda option)
+ (e:Typedtree.expression)
+ (p:Primitive.description)
+ (transl_list:(Covevent.lambda option -> Typedtree.expression list -> Lambda.lambda list))
+ (args:Typedtree.expression list)
+ in
+ let public_send = p.prim_name = "%send"
+ || not !Clflags.native_code && p.prim_name = "%sendcache"in
+ if public_send || p.prim_name = "%sendself" then
+ let kind = if public_send then Public else Self in
+ let obj = List.hd argl in
+ wrap (Lsend (kind, List.nth argl 1, obj, []))
+ else if p.prim_name = "%sendcache" then
+ match argl with [obj; meth; cache; pos] ->
+ wrap (Lsend(Cached, meth, obj, [cache; pos]))
+ | _ -> assert false
+ else
+ begin
+ let prim = transl_prim p args in
+ match (prim, args) with
+ (Praise, [arg1]) ->
+ wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
+ | (_, _) ->
+ begin match (prim, argl) with
+ | (Plazyforce, [a]) ->
+ wrap (Matching.inline_lazy_force a e.exp_loc)
+ | (Plazyforce, _) -> assert false
+ |_ ->
+ begin
+ match (Covutils.apply_prim_covev dec p e) with
+ | Covevent.Lcovev_statement
+ | Covevent.Lcovev_condition _ ->
+ Covutils.put e
+ (* (Covutils.apply_prim_covev dec p e) *)
+ Covevent.Lcovev_statement
+ (let p = Lprim(prim, argl) in
+ if primitive_is_ccall prim then wrap p else wrap0 p)
+ | Covevent.Lcovev_decision ->
+ let gdec = Some (Covutils.build_lambda_covev e Covevent.Lcovev_decision) in
+ let argl : Lambda.lambda list =
+ Covutils.apply_prim_put_dec
+ (gdec:Covevent.lambda option)
+ (e:Typedtree.expression)
+ (p:Primitive.description)
+ (transl_list:(Covevent.lambda option -> Typedtree.expression list -> Lambda.lambda list))
+ (args:Typedtree.expression list)
+ in
+ Covutils.put e (Covutils.apply_prim_covev dec p e)
+ (let p = Lprim(prim, argl) in
+ if primitive_is_ccall prim then wrap p else wrap0 p)
+ end
+ end
end
- end
- | Texp_apply(funct, oargs) ->
- event_after e (transl_apply (transl_exp funct) oargs e.exp_loc)
- | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
- Matching.for_multiple_match e.exp_loc
- (transl_list argl) (transl_cases pat_expr_list) partial
- | Texp_match(arg, pat_expr_list, partial) ->
- Matching.for_function e.exp_loc None
- (transl_exp arg) (transl_cases pat_expr_list) partial
- | Texp_try(body, pat_expr_list) ->
- let id = name_pattern "exn" pat_expr_list in
- Ltrywith(transl_exp body, id,
- Matching.for_trywith (Lvar id) (transl_cases pat_expr_list))
- | Texp_tuple el ->
- let ll = transl_list el in
- begin try
- Lconst(Const_block(0, List.map extract_constant ll))
- with Not_constant ->
- Lprim(Pmakeblock(0, Immutable), ll)
- end
- | Texp_construct(cstr, args) ->
- let ll = transl_list args in
- begin match cstr.cstr_tag with
- Cstr_constant n ->
- Lconst(Const_pointer n)
- | Cstr_block n ->
+
+ (* ****************************** APPLY (GENERAL) *******************************)
+ | Texp_apply(funct, oargs) ->
+ begin
+ match (Covutils.covevent_of_exp dec e) with
+ | Covevent.Lcovev_condition d -> (* dec is Some _ *)
+ begin
+ let gdec = Some (Covutils.build_lambda_covev e Covevent.Lcovev_decision) in
+ Covutils.put e (Covutils.covevent_of_exp dec e)
+ (event_after e (transl_apply gdec (transl_exp gdec funct) oargs e.exp_loc))
+ end
+ | Covevent.Lcovev_decision -> (* dec is None *)
+ let gdec = Some (Covutils.build_lambda_covev e Covevent.Lcovev_decision) in
+ Covutils.put e (Covutils.covevent_of_exp (dec) e)
+ (* something not right below vvvv vvvv*)
+ (event_after e (transl_apply gdec (transl_exp gdec funct) oargs e.exp_loc))
+ | Covevent.Lcovev_statement -> (* expr is not Boolean *)
+ Covutils.put e (Covutils.covevent_of_exp dec e)
+ (event_after e (transl_apply dec (transl_exp dec funct) oargs e.exp_loc))
+ end
+
+
+ | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
+ Matching.for_multiple_match e.exp_loc
+ (transl_list dec argl)
+ (transl_cases dec pat_expr_list)
+ partial
+ | Texp_match(arg, pat_expr_list, partial) ->
+ Matching.for_function e.exp_loc None
+ (transl_exp dec arg) (transl_cases dec pat_expr_list) partial
+ | Texp_try(body, pat_expr_list) ->
+ let id = name_pattern "exn" pat_expr_list in
+ Ltrywith(transl_exp dec body, id,
+ Matching.for_trywith (Lvar id) (transl_cases dec pat_expr_list))
+ | Texp_tuple el ->
+ let ll = transl_list dec el in
begin try
- Lconst(Const_block(n, List.map extract_constant ll))
- with Not_constant ->
- Lprim(Pmakeblock(n, Immutable), ll)
+ Lconst(Const_block(0, List.map extract_constant ll))
+ with Not_constant ->
+ Lprim(Pmakeblock(0, Immutable), ll)
end
- | Cstr_exception path ->
- Lprim(Pmakeblock(0, Immutable), transl_path path :: ll)
- end
- | Texp_variant(l, arg) ->
- let tag = Btype.hash_variant l in
- begin match arg with
- None -> Lconst(Const_pointer tag)
- | Some arg ->
- let lam = transl_exp arg in
- try
- Lconst(Const_block(0, [Const_base(Const_int tag);
- extract_constant lam]))
- with Not_constant ->
- Lprim(Pmakeblock(0, Immutable),
- [Lconst(Const_base(Const_int tag)); lam])
- end
- | Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
- transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
- | Texp_record ([], _) ->
- fatal_error "Translcore.transl_exp: bad Texp_record"
- | Texp_field(arg, lbl) ->
- let access =
- match lbl.lbl_repres with
- Record_regular -> Pfield lbl.lbl_pos
- | Record_float -> Pfloatfield lbl.lbl_pos in
- Lprim(access, [transl_exp arg])
- | Texp_setfield(arg, lbl, newval) ->
- let access =
- match lbl.lbl_repres with
- Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
- | Record_float -> Psetfloatfield lbl.lbl_pos in
- Lprim(access, [transl_exp arg; transl_exp newval])
- | Texp_array expr_list ->
- let kind = array_kind e in
- let ll = transl_list expr_list in
- begin try
- (* Deactivate constant optimization if array is small enough *)
- if List.length ll <= 4 then raise Not_constant;
- let cl = List.map extract_constant ll in
- let master =
- match kind with
- | Paddrarray | Pintarray ->
- Lconst(Const_block(0, cl))
- | Pfloatarray ->
- Lconst(Const_float_array(List.map extract_float cl))
- | Pgenarray ->
- raise Not_constant in (* can this really happen? *)
- Lprim(Pccall prim_obj_dup, [master])
- with Not_constant ->
- Lprim(Pmakearray kind, ll)
- end
- | Texp_ifthenelse(cond, ifso, Some ifnot) ->
- Lifthenelse(transl_exp cond,
- event_before ifso (transl_exp ifso),
- event_before ifnot (transl_exp ifnot))
- | Texp_ifthenelse(cond, ifso, None) ->
- Lifthenelse(transl_exp cond,
- event_before ifso (transl_exp ifso),
- lambda_unit)
- | Texp_sequence(expr1, expr2) ->
- Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2))
- | Texp_while(cond, body) ->
- Lwhile(transl_exp cond, event_before body (transl_exp body))
- | Texp_for(param, low, high, dir, body) ->
- Lfor(param, transl_exp low, transl_exp high, dir,
- event_before body (transl_exp body))
- | Texp_when(cond, body) ->
- event_before cond
- (Lifthenelse(transl_exp cond, event_before body (transl_exp body),
- staticfail))
- | Texp_send(expr, met) ->
- let obj = transl_exp expr in
- let lam =
- match met with
- Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
- | Tmeth_name nm ->
- let (tag, cache) = Translobj.meth obj nm in
- let kind = if cache = [] then Public else Cached in
- Lsend (kind, tag, obj, cache)
- in
- event_after e lam
- | Texp_new (cl, _) ->
- Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)
- | Texp_instvar(path_self, path) ->
- Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
- | Texp_setinstvar(path_self, path, expr) ->
- transl_setinstvar (transl_path path_self) path expr
- | Texp_override(path_self, modifs) ->
- let cpy = Ident.create "copy" in
- Llet(Strict, cpy,
- Lapply(Translobj.oo_prim "copy", [transl_path path_self],
- Location.none),
- List.fold_right
- (fun (path, expr) rem ->
- Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
- modifs
- (Lvar cpy))
- | Texp_letmodule(id, modl, body) ->
- Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body)
- | Texp_pack modl ->
- !transl_module Tcoerce_none None modl
- | Texp_assert (cond) ->
- if !Clflags.noassert
- then lambda_unit
- else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc)
- | Texp_assertfalse -> assert_failed e.exp_loc
- | Texp_lazy e ->
- (* when e needs no computation (constants, identifiers, ...), we
- optimize the translation just as Lazy.lazy_from_val would
- do *)
- begin match e.exp_desc with
- (* a constant expr of type <> float gets compiled as itself *)
- | Texp_constant
- ( Const_int _ | Const_char _ | Const_string _
- | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
- | Texp_function(_, _)
- | Texp_construct ({cstr_arity = 0}, _)
- -> transl_exp e
- | Texp_constant(Const_float _) ->
- Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
- | Texp_ident(_, _) -> (* according to the type *)
- begin match e.exp_type.desc with
- (* the following may represent a float/forward/lazy: need a
- forward_tag *)
- | Tvar | Tlink _ | Tsubst _ | Tunivar
- | Tpoly(_,_) | Tfield(_,_,_,_) ->
- Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
- (* the following cannot be represented as float/forward/lazy:
- optimize *)
- | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil | Tvariant _
- -> transl_exp e
- (* optimize predefined types (excepted float) *)
- | Tconstr(_,_,_) ->
- if has_base_type e Predef.path_int
- || has_base_type e Predef.path_char
- || has_base_type e Predef.path_string
- || has_base_type e Predef.path_bool
- || has_base_type e Predef.path_unit
- || has_base_type e Predef.path_exn
- || has_base_type e Predef.path_array
- || has_base_type e Predef.path_list
- || has_base_type e Predef.path_format6
- || has_base_type e Predef.path_option
- || has_base_type e Predef.path_nativeint
- || has_base_type e Predef.path_int32
- || has_base_type e Predef.path_int64
- then transl_exp e
- else
- Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
+ | Texp_construct(cstr, args) ->
+ let ll = transl_list dec args in
+ begin match cstr.cstr_tag with
+ Cstr_constant n ->
+ Covutils.put e Covevent.Lcovev_statement (Lconst(Const_pointer n))
+ | Cstr_block n ->
+ begin try
+ Covutils.put e Covevent.Lcovev_statement
+ (Lconst(Const_block(n, List.map extract_constant ll)))
+ with Not_constant ->
+ Covutils.put e Covevent.Lcovev_statement
+ (Lprim(Pmakeblock(n, Immutable), ll))
+ end
+ | Cstr_exception path ->
+ Covutils.put e Covevent.Lcovev_statement
+ (Lprim(Pmakeblock(0, Immutable), transl_path path :: ll))
+ end
+ | Texp_variant(l, arg) ->
+ let tag = Btype.hash_variant l in
+ begin match arg with
+ None -> Lconst(Const_pointer tag)
+ | Some arg ->
+ let lam = transl_exp dec arg in
+ try
+ Lconst(Const_block(0, [Const_base(Const_int tag);
+ extract_constant lam]))
+ with Not_constant ->
+ Lprim(Pmakeblock(0, Immutable),
+ [Lconst(Const_base(Const_int tag)); lam])
end
- (* other cases compile to a lazy block holding a function *)
- | _ ->
- let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
- Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
- end
- | Texp_object (cs, cty, meths) ->
- let cl = Ident.create "class" in
- !transl_object cl meths
- { cl_desc = Tclass_structure cs;
- cl_loc = e.exp_loc;
- cl_type = Tcty_signature cty;
- cl_env = e.exp_env }
+ | Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
+ transl_record dec lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
+ | Texp_record ([], _) ->
+ fatal_error "Translcore.transl_exp: bad Texp_record"
+ | Texp_field(arg, lbl) ->
+ begin
+ let gdec =
+ if Covutils.is_bool e.exp_type.desc && dec = None then
+ Some (Covutils.build_lambda_covev e Covevent.Lcovev_decision)
+ else
+ dec
+ in
+ let access =
+ match lbl.lbl_repres with
+ Record_regular -> Pfield lbl.lbl_pos
+ | Record_float -> Pfloatfield lbl.lbl_pos in
+ Covutils.put e (Covutils.covevent_of_exp dec e)
+ (Lprim(access, [transl_exp gdec arg]))
+ end
+ | Texp_setfield(arg, lbl, newval) ->
+ let access =
+ match lbl.lbl_repres with
+ Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
+ | Record_float -> Psetfloatfield lbl.lbl_pos in
+ Covutils.put e (Covutils.covevent_of_exp dec e)
+ (Lprim(access, [transl_exp dec arg; transl_exp dec newval]))
+ | Texp_array expr_list ->
+ let kind = array_kind e in
+ let ll = transl_list dec expr_list in
+ begin try
+ (* Deactivate constant optimization if array is small enough *)
+ if List.length ll <= 4 then raise Not_constant;
+ let cl = List.map extract_constant ll in
+ let master =
+ match kind with
+ | Paddrarray | Pintarray ->
+ Lconst(Const_block(0, cl))
+ | Pfloatarray ->
+ Lconst(Const_float_array(List.map extract_float cl))
+ | Pgenarray ->
+ raise Not_constant in (* can this really happen? *)
+ Lprim(Pccall prim_obj_dup, [master])
+ with Not_constant ->
+ Lprim(Pmakearray kind, ll)
+ end
+ | Texp_ifthenelse(cond, ifso, Some ifnot) ->
+ begin
+ if Covutils.is_bool e.exp_type.desc && dec = None then
+ let gdec =
+ Some (Covutils.build_lambda_covev e Covevent.Lcovev_decision)
+ in
+ Covutils.put e (Covutils.covevent_of_exp dec e)
+ (Lifthenelse(transl_exp gdec cond,
+ event_before ifso (transl_exp gdec ifso),
+ event_before ifnot (transl_exp gdec ifnot)))
+ else
+ Covutils.put e (Covutils.covevent_of_exp dec e)
+ (Lifthenelse(transl_exp dec cond,
+ event_before ifso (transl_exp dec ifso),
+ event_before ifnot (transl_exp dec ifnot)))
+ end
+ | Texp_ifthenelse(cond, ifso, None) ->
+ Lifthenelse(transl_exp dec cond,
+ event_before ifso (transl_exp dec ifso),
+ lambda_unit)
+ | Texp_sequence(expr1, expr2) ->
+ Lsequence(transl_exp dec expr1, event_before expr2 (transl_exp dec expr2))
+ | Texp_while(cond, body) ->
+ (* no dec transmission to loops *)
+ Lwhile(transl_exp None cond, event_before body (transl_exp None body))
+ | Texp_for(param, low, high, dir, body) ->
+ (* no dec transmission to loops *)
+ Lfor(param, transl_exp None low, transl_exp dec high, dir,
+ event_before body (transl_exp None body))
+ | Texp_when(cond, body) ->
+ event_before cond
+ (Lifthenelse(transl_exp dec cond, event_before body (transl_exp dec body),
+ staticfail))
+ | Texp_send(expr, met) ->
+ let obj = transl_exp dec expr in
+ let lam =
+ match met with
+ Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
+ | Tmeth_name nm ->
+ let (tag, cache) = Translobj.meth obj nm in
+ let kind = if cache = [] then Public else Cached in
+ Lsend (kind, tag, obj, cache)
+ in
+ event_after e lam
+ | Texp_new (cl, _) ->
+ Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)
+ | Texp_instvar(path_self, path) ->
+ Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
+ | Texp_setinstvar(path_self, path, expr) ->
+ transl_setinstvar dec (transl_path path_self) path expr
+ | Texp_override(path_self, modifs) ->
+ let cpy = Ident.create "copy" in
+ Llet(Strict, cpy,
+ Lapply(Translobj.oo_prim "copy", [transl_path path_self],
+ Location.none),
+ List.fold_right
+ (fun (path, expr) rem ->
+ Lsequence(transl_setinstvar dec (Lvar cpy) path expr, rem))
+ modifs
+ (Lvar cpy))
+ | Texp_letmodule(id, modl, body) ->
+ Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp dec body)
+ | Texp_pack modl ->
+ !transl_module Tcoerce_none None modl
+ | Texp_assert (cond) ->
+ if !Clflags.noassert
+ then lambda_unit
+ else Lifthenelse (transl_exp dec cond, lambda_unit, assert_failed e.exp_loc)
+ | Texp_assertfalse -> assert_failed e.exp_loc
+ | Texp_lazy e ->
+ (* when e needs no computation (constants, identifiers, ...), we
+ optimize the translation just as Lazy.lazy_from_val would
+ do *)
+ begin match e.exp_desc with
+ (* a constant expr of type <> float gets compiled as itself *)
+ | Texp_constant
+ ( Const_int _ | Const_char _ | Const_string _
+ | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
+ | Texp_function(_, _)
+ | Texp_construct ({cstr_arity = 0}, _)
+ -> transl_exp dec e
+ | Texp_constant(Const_float _) ->
+ Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp dec e])
+ | Texp_ident(_, _) -> (* according to the type *)
+ begin match e.exp_type.desc with
+ (* the following may represent a float/forward/lazy: need a
+ forward_tag *)
+ | Tvar | Tlink _ | Tsubst _ | Tunivar
+ | Tpoly(_,_) | Tfield(_,_,_,_) ->
+ Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp dec e])
+ (* the following cannot be represented as float/forward/lazy:
+ optimize *)
+ | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil | Tvariant _
+ -> transl_exp dec e
+ (* optimize predefined types (excepted float) *)
+ | Tconstr(_,_,_) ->
+ if has_base_type e Predef.path_int
+ || has_base_type e Predef.path_char
+ || has_base_type e Predef.path_string
+ || has_base_type e Predef.path_bool
+ || has_base_type e Predef.path_unit
+ || has_base_type e Predef.path_exn
+ || has_base_type e Predef.path_array
+ || has_base_type e Predef.path_list
+ || has_base_type e Predef.path_format6
+ || has_base_type e Predef.path_option
+ || has_base_type e Predef.path_nativeint
+ || has_base_type e Predef.path_int32
+ || has_base_type e Predef.path_int64
+ then transl_exp dec e
+ else
+ Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp dec e])
+ end
+ (* other cases compile to a lazy block holding a function *)
+ | _ ->
+ let fn = Lfunction (Curried, [Ident.create "param"], transl_exp dec e) in
+ Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
+ end
+ | Texp_object (cs, cty, meths) ->
+ let cl = Ident.create "class" in
+ !transl_object cl meths
+ { cl_desc = Tclass_structure cs;
+ cl_loc = e.exp_loc;
+ cl_type = Tcty_signature cty;
+ cl_env = e.exp_env }
-and transl_list expr_list =
- List.map transl_exp expr_list
+and transl_list (dec:Covevent.lambda option) expr_list =
+ List.map (transl_exp dec) expr_list
-and transl_cases pat_expr_list =
+and transl_cases dec pat_expr_list =
List.map
- (fun (pat, expr) -> (pat, event_before expr (transl_exp expr)))
+ (fun (pat, expr) -> (pat, event_before expr (transl_exp dec expr)))
pat_expr_list
-and transl_tupled_cases patl_expr_list =
- List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
+and transl_tupled_cases dec patl_expr_list =
+ List.map (fun (patl, expr) -> (patl, transl_exp dec expr)) patl_expr_list
-and transl_apply lam sargs loc =
+and transl_apply dec lam sargs loc =
let lapply funct args =
match funct with
- Lsend(k, lmet, lobj, largs) ->
- Lsend(k, lmet, lobj, largs @ args)
- | Levent(Lsend(k, lmet, lobj, largs), _) ->
- Lsend(k, lmet, lobj, largs @ args)
- | Lapply(lexp, largs, _) ->
- Lapply(lexp, largs @ args, loc)
- | lexp ->
- Lapply(lexp, args, loc)
+ Lsend(k, lmet, lobj, largs) ->
+ Lsend(k, lmet, lobj, largs @ args)
+ | Levent(Lsend(k, lmet, lobj, largs), _) ->
+ Lsend(k, lmet, lobj, largs @ args)
+ | Lapply(lexp, largs, _) ->
+ Lapply(lexp, largs @ args, loc)
+ | lexp ->
+ Lapply(lexp, args, loc)
in
let rec build_apply lam args = function
(None, optional) :: l ->
let defs = ref [] in
let protect name lam =
match lam with
- Lvar _ | Lconst _ -> lam
- | _ ->
- let id = Ident.create name in
- defs := (id, lam) :: !defs;
- Lvar id
+ Lvar _ | Lconst _ -> lam
+ | _ ->
+ let id = Ident.create name in
+ defs := (id, lam) :: !defs;
+ Lvar id
in
let args, args' =
if List.for_all (fun (_,opt) -> opt = Optional) args then [], args
@@ -870,147 +960,152 @@
and id_arg = Ident.create "param" in
let body =
match build_apply handle ((Lvar id_arg, optional)::args') l with
- Lfunction(Curried, ids, lam) ->
- Lfunction(Curried, id_arg::ids, lam)
- | Levent(Lfunction(Curried, ids, lam), _) ->
- Lfunction(Curried, id_arg::ids, lam)
- | lam ->
- Lfunction(Curried, [id_arg], lam)
+ Lfunction(Curried, ids, lam) ->
+ Lfunction(Curried, id_arg::ids, lam)
+ | Levent(Lfunction(Curried, ids, lam), _) ->
+ Lfunction(Curried, id_arg::ids, lam)
+ | lam ->
+ Lfunction(Curried, [id_arg], lam)
in
- List.fold_left
- (fun body (id, lam) -> Llet(Strict, id, lam, body))
- body !defs
+ List.fold_left
+ (fun body (id, lam) -> Llet(Strict, id, lam, body))
+ body !defs
| (Some arg, optional) :: l ->
build_apply lam ((arg, optional) :: args) l
| [] ->
lapply lam (List.rev_map fst args)
in
- build_apply lam [] (List.map (fun (x,o) -> may_map transl_exp x, o) sargs)
+ build_apply lam [] (List.map (fun (x,o) -> may_map (transl_exp dec) x, o) sargs)
-and transl_function loc untuplify_fn repr partial pat_expr_list =
+and transl_function dec loc untuplify_fn repr partial pat_expr_list =
match pat_expr_list with
- [pat, ({exp_desc = Texp_function(pl,partial')} as exp)]
- when Parmatch.fluid pat ->
- let param = name_pattern "param" pat_expr_list in
- let ((_, params), body) =
- transl_function exp.exp_loc false repr partial' pl in
- ((Curried, param :: params),
- Matching.for_function loc None (Lvar param) [pat, body] partial)
- | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
- begin try
- let size = List.length pl in
- let pats_expr_list =
- List.map
- (fun (pat, expr) -> (Matching.flatten_pattern size pat, expr))
- pat_expr_list in
- let params = List.map (fun p -> Ident.create "param") pl in
- ((Tupled, params),
- Matching.for_tupled_function loc params
- (transl_tupled_cases pats_expr_list) partial)
- with Matching.Cannot_flatten ->
+ [pat, ({exp_desc = Texp_function(pl,partial')} as exp)]
+ when Parmatch.fluid pat ->
+ let param = name_pattern "param" pat_expr_list in
+ let ((_, params), body) =
+ transl_function dec exp.exp_loc false repr partial' pl in
+ ((Curried, param :: params),
+ Matching.for_function loc None (Lvar param) [pat, body] partial)
+ | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
+ begin try
+ let size = List.length pl in
+ let pats_expr_list =
+ List.map
+ (fun (pat, expr) -> (Matching.flatten_pattern size pat, expr))
+ pat_expr_list in
+ let params = List.map (fun p -> Ident.create "param") pl in
+ ((Tupled, params),
+ Matching.for_tupled_function loc params
+ (transl_tupled_cases dec pats_expr_list) partial)
+ with Matching.Cannot_flatten ->
+ let param = name_pattern "param" pat_expr_list in
+ ((Curried, [param]),
+ Matching.for_function loc repr (Lvar param)
+ (transl_cases dec pat_expr_list) partial)
+ end
+ | _ ->
let param = name_pattern "param" pat_expr_list in
- ((Curried, [param]),
- Matching.for_function loc repr (Lvar param)
- (transl_cases pat_expr_list) partial)
- end
- | _ ->
- let param = name_pattern "param" pat_expr_list in
- ((Curried, [param]),
- Matching.for_function loc repr (Lvar param)
- (transl_cases pat_expr_list) partial)
+ ((Curried, [param]),
+ Matching.for_function loc repr (Lvar param)
+ (transl_cases dec pat_expr_list) partial)
-and transl_let rec_flag pat_expr_list body =
+and transl_let dec rec_flag pat_expr_list body =
match rec_flag with
- Nonrecursive | Default ->
- let rec transl = function
- [] ->
- body
- | (pat, expr) :: rem ->
- Matching.for_let pat.pat_loc (transl_exp expr) pat (transl rem)
- in transl pat_expr_list
- | Recursive ->
- let idlist =
- List.map
- (fun (pat, expr) ->
- match pat.pat_desc with
- Tpat_var id -> id
- | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))
- pat_expr_list in
- let transl_case (pat, expr) id =
- let lam = transl_exp expr in
- if not (check_recursive_lambda idlist lam) then
- raise(Error(expr.exp_loc, Illegal_letrec_expr));
- (id, lam) in
- Lletrec(List.map2 transl_case pat_expr_list idlist, body)
+ Nonrecursive | Default ->
+ let rec transl = function
+ [] ->
+ body
+ | (pat, expr) :: rem ->
+ Matching.for_let pat.pat_loc (transl_exp dec expr) pat (transl rem)
+ in transl pat_expr_list
+ | Recursive ->
+ let idlist =
+ List.map
+ (fun (pat, expr) ->
+ match pat.pat_desc with
+ Tpat_var id -> id
+ | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))
+ pat_expr_list in
+ let transl_case (pat, expr) id =
+ let lam = transl_exp dec expr in
+ if not (check_recursive_lambda idlist lam) then
+ raise(Error(expr.exp_loc, Illegal_letrec_expr));
+ (id, lam) in
+ Lletrec(List.map2 transl_case pat_expr_list idlist, body)
-and transl_setinstvar self var expr =
+and transl_setinstvar dec self var expr =
Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
- [self; transl_path var; transl_exp expr])
+ [self; transl_path var; transl_exp dec expr])
-and transl_record all_labels repres lbl_expr_list opt_init_expr =
+and transl_record dec all_labels repres lbl_expr_list opt_init_expr =
let size = Array.length all_labels in
- (* Determine if there are "enough" new fields *)
- if 3 + 2 * List.length lbl_expr_list >= size
- then begin
- (* Allocate new record with given fields (and remaining fields
- taken from init_expr if any *)
- let lv = Array.create (Array.length all_labels) staticfail in
- let init_id = Ident.create "init" in
- begin match opt_init_expr with
- None -> ()
- | Some init_expr ->
- for i = 0 to Array.length all_labels - 1 do
- let access =
- match all_labels.(i).lbl_repres with
- Record_regular -> Pfield i
- | Record_float -> Pfloatfield i in
- lv.(i) <- Lprim(access, [Lvar init_id])
- done
- end;
- List.iter
- (fun (lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr)
- lbl_expr_list;
- let ll = Array.to_list lv in
- let mut =
- if List.exists (fun (lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list
- then Mutable
- else Immutable in
- let lam =
- try
- if mut = Mutable then raise Not_constant;
- let cl = List.map extract_constant ll in
- match repres with
- Record_regular -> Lconst(Const_block(0, cl))
- | Record_float ->
- Lconst(Const_float_array(List.map extract_float cl))
- with Not_constant ->
- match repres with
- Record_regular -> Lprim(Pmakeblock(0, mut), ll)
- | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in
- begin match opt_init_expr with
- None -> lam
- | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam)
- end
- end else begin
- (* Take a shallow copy of the init record, then mutate the fields
- of the copy *)
- (* If you change anything here, you will likely have to change
- [check_recursive_recordwith] in this file. *)
- let copy_id = Ident.create "newrecord" in
- let rec update_field (lbl, expr) cont =
- let upd =
- match lbl.lbl_repres with
- Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
- | Record_float -> Psetfloatfield lbl.lbl_pos in
- Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in
- begin match opt_init_expr with
- None -> assert false
- | Some init_expr ->
- Llet(Strict, copy_id,
- Lprim(Pduprecord (repres, size), [transl_exp init_expr]),
- List.fold_right update_field lbl_expr_list (Lvar copy_id))
+ (* Determine if there are "enough" new fields *)
+ if 3 + 2 * List.length lbl_expr_list >= size
+ then begin
+ (* Allocate new record with given fields (and remaining fields
+ taken from init_expr if any *)
+ let lv = Array.create (Array.length all_labels) staticfail in
+ let init_id = Ident.create "init" in
+ begin match opt_init_expr with
+ None -> ()
+ | Some init_expr ->
+ for i = 0 to Array.length all_labels - 1 do
+ let access =
+ match all_labels.(i).lbl_repres with
+ Record_regular -> Pfield i
+ | Record_float -> Pfloatfield i in
+ lv.(i) <- Lprim(access, [Lvar init_id])
+ done
+ end;
+ List.iter
+ (fun (lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp dec expr)
+ lbl_expr_list;
+ let ll = Array.to_list lv in
+ let mut =
+ if List.exists (fun (lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list
+ then Mutable
+ else Immutable in
+ let lam =
+ try
+ if mut = Mutable then raise Not_constant;
+ let cl = List.map extract_constant ll in
+ match repres with
+ Record_regular -> Lconst(Const_block(0, cl))
+ | Record_float ->
+ Lconst(Const_float_array(List.map extract_float cl))
+ with Not_constant ->
+ match repres with
+ Record_regular -> Lprim(Pmakeblock(0, mut), ll)
+ | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in
+ begin match opt_init_expr with
+ None -> lam
+ | Some init_expr -> Llet(Strict, init_id, transl_exp dec init_expr, lam)
+ end
+ end else begin
+ (* Take a shallow copy of the init record, then mutate the fields
+ of the copy *)
+ (* If you change anything here, you will likely have to change
+ [check_recursive_recordwith] in this file. *)
+ let copy_id = Ident.create "newrecord" in
+ let rec update_field (lbl, expr) cont =
+ let upd =
+ match lbl.lbl_repres with
+ Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
+ | Record_float -> Psetfloatfield lbl.lbl_pos in
+ Lsequence(Lprim(upd, [Lvar copy_id; transl_exp dec expr]), cont) in
+ begin match opt_init_expr with
+ None -> assert false
+ | Some init_expr ->
+ Llet(Strict, copy_id,
+ Lprim(Pduprecord (repres, size), [transl_exp dec init_expr]),
+ List.fold_right update_field lbl_expr_list (Lvar copy_id))
+ end
end
- end
+
+
+let transl_exp = transl_exp None
+let transl_apply = transl_apply None
+let transl_let = transl_let None
(* Wrapper for class compilation *)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment