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

merge

master
Mark Shinwell 2016-01-29 14:43:38 +00:00
parent b526d25d6a af2669f0a0
commit 355cf1d40b
330 changed files with 8752 additions and 1708 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1264
.depend
View File

File diff suppressed because it is too large Load Diff

9
.gitattributes vendored
View File

@ -44,6 +44,11 @@ ocamldoc/ocamldoc.sty ocaml-typo=missing-header
*.sh.in text eol=lf
*.awk text eol=lf
# Test suite command fragments
*.checker text eol=lf
*.precheck text eol=lf
*.runner text eol=lf
configure text eol=lf
config/auto-aux/hasgot text eol=lf
config/auto-aux/hasgot2 text eol=lf
@ -79,3 +84,7 @@ manual/tools/htmlcut text eol=lf
manual/tools/htmltbl text eol=lf
manual/tools/htmlthread text eol=lf
manual/tools/texexpand text eol=lf
# Checking out the parsetree test files with \r\n endings causes all the
# locations to change, so use \n endings only, even on Windows
testsuite/tests/parsing/*.ml text eol=lf

17
.gitignore vendored
View File

@ -17,6 +17,7 @@
.DS_Store
*.out
*.out.dSYM
*.swp
# local to root directory
@ -133,6 +134,8 @@
/ocamlbuild/ocamlbuild_config.ml
/ocamlbuild/lexers.ml
/ocamlbuild/glob_lexer.ml
/ocamlbuild/ocamlbuild.native
/ocamlbuild/ocamlbuild.byte
/ocamldoc/ocamldoc
/ocamldoc/ocamldoc.opt
@ -213,6 +216,8 @@
/testsuite/**/program
/testsuite/**/_log
/testsuite/_retries
/testsuite/tests/asmcomp/codegen
/testsuite/tests/asmcomp/parsecmm.ml
/testsuite/tests/asmcomp/parsecmm.mli
@ -238,6 +243,8 @@
/testsuite/tests/lib-threads/*.byt
/testsuite/tests/opaque/*/*.mli
/testsuite/tests/runtime-errors/*.bytecode
/testsuite/tests/tool-debugger/**/compiler-libs
@ -245,10 +252,20 @@
/testsuite/tests/tool-debugger/no_debug_event/out
/testsuite/tests/tool-debugger/no_debug_event/c
/testsuite/tests/tool-ocamldep-modalias/*.byt*
/testsuite/tests/tool-ocamldep-modalias/*.opt*
/testsuite/tests/tool-ocamldep-modalias/depend.mk
/testsuite/tests/tool-ocamldep-modalias/depend.mk2
/testsuite/tests/tool-ocamldep-modalias/depend.mod
/testsuite/tests/tool-ocamldep-modalias/depend.mod2
/testsuite/tests/tool-ocamldep-modalias/depend.mod3
/testsuite/tests/tool-ocamldoc/*.html
/testsuite/tests/tool-ocamldoc/*.sty
/testsuite/tests/tool-ocamldoc/*.css
/testsuite/tests/tool-ocamldoc-2/ocamldoc.sty
/testsuite/tests/tool-lexyacc/scanner.ml
/testsuite/tests/tool-lexyacc/grammar.mli
/testsuite/tests/tool-lexyacc/grammar.ml

3
.gitmodules vendored Normal file
View File

@ -0,0 +1,3 @@
[submodule "flexdll"]
path = flexdll
url = https://github.com/alainfrisch/flexdll.git

6
.merlin
View File

@ -1,6 +1,12 @@
S ./asmcomp
B ./asmcomp
S ./middle_end
B ./middle_end
S ./middle_end/base_types
B ./middle_end/base_types
S ./bytecomp
B ./bytecomp

3
.travis-ci.sh
View File

@ -29,11 +29,12 @@ control.
------------------------------------------------------------------------
EOF
mkdir -p $PREFIX
./configure --prefix $PREFIX
./configure --prefix $PREFIX -with-debug-runtime -with-instrumented-runtime
export PATH=$PREFIX/bin:$PATH
make world.opt
make install
(cd testsuite && make all)
(cd testsuite && make USE_RUNTIME="d" all)
mkdir external-packages
cd external-packages
git clone git://github.com/ocaml/camlp4

2
.travis.yml
View File

@ -12,6 +12,8 @@
sudo: false
language: c
git:
submodules: false
script: bash -ex .travis-ci.sh
matrix:
include:

53
Changes
View File

@ -10,7 +10,7 @@ Language features:
Namely, the redundancy checker now checks whether the uncovered pattern
of the pattern is actually inhabited, exploding at most one wild card.
This is also done for exhaustiveness when there is only one case.
Additionnally, one can now write unreachable cases, of the form,
Additionally, one can now write unreachable cases, of the form,
"pat -> .", which are treated by the redundancy check. (Jacques Garrigue)
- PR#6374: allow "_ t" as a short-hand for "(_, _, ..) t" for n-ary type
constructors (Alain Frisch)
@ -24,6 +24,8 @@ Language features:
- GPR#88: allow field punning in object copying expressions:
{< x; y; >} is sugar for {< x = x; y = y; >}
(Jeremy Yallop)
- GPR#112: octal escape sequences for char and string literals
(Rafaël Bocquet)
- GPR#167: allow to annotate externals' arguments and result types so
they can be unboxed or untagged. Supports untagging int and unboxing
int32, int64, nativeint and float.
@ -58,6 +60,9 @@ Language features:
- PR#6681 GPR#326: signature items are now accepted as payloads for
extension and attributes, using the syntax [%foo: SIG ] or [@foo: SIG ].
(Alain Frisch and Gabriel Radanne)
* GPR#234: allow "[]" as a user-defined constructor. Demand parenthesis
around "::" when using "::" as user-defined constructor.
(Runhang Li, review by Damien Doligez)
Compilers:
- PR#4080, PR#6537, PR#5333: fix stack overflow in the compiler when -pack'ing
@ -84,6 +89,8 @@ Compilers:
(Jérémie Dimino, Alain Frisch)
* PR#6438: Pattern guard disables exhaustiveness check
(Alain Frisch)
- PR#6920: fix debug informations around uses of %apply or %revapply
(Jérémie Dimino)
- PR#6939: Segfault with improper use of let-rec (Alain Frisch)
- PR#6943: native-code generator for POWER/PowerPC 64 bits, both in
big-endian (ppc64) and little-endian (ppc64le) configuration.
@ -101,8 +108,8 @@ Compilers:
- PR#7067: Performance regression in the native compiler for long
nested structures (Alain Frisch, report by Daniel Bünzli, review
by Jacques Garrigue)
- PR#7097: Strange syntax error message around illegal packaged module signature
constraints (Alain Frisch, report by Jun Furuse)
- PR#7097: Strange syntax error message around illegal packaged module
signature constraints (Alain Frisch, report by Jun Furuse)
- GPR#17: some cmm optimizations of integer operations with constants
(Stephen Dolan, review by Pierre Chambart)
- GPR#109: new unboxing strategy for float and int references (Vladimir Brankov,
@ -111,6 +118,8 @@ Compilers:
(Vladimir Brankov, review by Alain Frisch)
- GPR#115: More precise typing of values at the C-- and Mach level,.
(Xavier Leroy, review by Pierre Chambart)
- GPR#132: Flambda: new intermediate language and "middle-end" optimizers
(Pierre Chambart, Mark Shinwell, Leo White)
- GPR#207: Colors in compiler messages (warnings, errors)
(Simon Cruanes, review by Gabriel Scherer)
- GPR#258: more precise information on PowerPC instruction sizes
@ -136,7 +145,14 @@ Compilers:
- GPR#319: add warning for missing cmx files, and extend -opaque option to mli
files.
(Leo White)
- PR#6920: fix debug informations around uses of %apply or %revapply
- GPR#388: OCAML_FLEXLINK environment variable allows overriding flexlink
command (David Allsopp)
- GPR#407: don't display the name of compiled .c files when calling the
Microsoft C Compiler (same as the assembler).
(David Allsopp)
- GPR#431: permit constant float arrays to be eligible for pattern match
branch merging (Pierre Chambart)
- GPR#392: put all parsetree invariants in a new module Ast_invariants
(Jérémie Dimino)
Runtime system:
@ -227,10 +243,14 @@ Standard library:
* Sys.time (and [@@noalloc])
* Pervasives.ldexp (and [@@noalloc])
* Pervasives.compare for float, nativeint, int32, int64.
(Bobot François)
(François Bobot)
- GPR#329: Add exists, for_all, mem and memq functions in Array
(Bernhard Schommer)
- GPR#337: Add [Hashtbl.filter_map_inplace] (Alain Frisch)
- GPR#356: Add [Format.kasprintf] (Jérémie Dimino, Mark Shinwell)
- GPR#22: Add the Ephemeron module that implements ephemerons and weak
hash table (François Bobot, review by Damien Doligez, Daniel Bünzli,
Alain Frisch, Pierre Chambart)
Type system:
- PR#5545: Type annotations on methods cannot control the choice of abbreviation
@ -272,6 +292,9 @@ Other libraries:
Before, a handled signal could cause Unix.sleep to return early.
Now, the sleep is restarted until the given time is elapsed.
(Xavier Leroy)
- PR#6263: add kind_size_in_bytes and size_in_bytes functions
to Bigarray module.
(Runhang Li, review by Mark Shinwell)
- PR#6289: Unix.utimes uses the current time only if both arguments
are exactly 0.0. Also, use sub-second resolution if available.
(Xavier Leroy, report by Christophe Troestler)
@ -299,7 +322,7 @@ OCamlbuild:
(Vincent Laporte)
OCamldep:
- GRP#286: add support for module aliases
- GPR#286: add support for module aliases
(jacques Garrigue)
Manual:
@ -440,6 +463,12 @@ Bug fixes:
Mark Shinwell)
- GPR#283: Fix memory leaks in intern.c when OOM is raised
(Marc Lasson, review by Alain Frisch)
- GPR#22: Fix the cleaning of weak pointers. In very rare cases
accessing a value during the cleaning of the weak pointers could
result in the value being removed from one weak arrays and kept in
another one. That breaks the property that a value is removed from a
weak pointer only when it is dead and garbage collected. (François
Bobot, review by Damien Doligez)
- GPR#313: Prevent quadratic cases in CSE
(Pierre Chambart, review by Xavier Leroy)
- PR#6795, PR#6996: Make ocamldep report errors passed in
@ -449,6 +478,10 @@ Bug fixes:
(Jérémie Dimino, Thomas Refis)
- GPR#405: fix compilation under Visual Studio 2015
(David Allsopp)
- GPR#441: better type error location in presence of type constraints
(Thomas Refis, report by Arseniy Alekseyev)
- PR#7111: reject empty let bindings instead of printing incorrect syntax
(Jérémie Dimino)
Features wishes:
- PR#4518, GPR#29: change location format for reporting errors in ocamldoc
@ -515,10 +548,18 @@ Features wishes:
(Hugo Heuzard)
- GPR#308: add experimental support for NetBSD/arm (verified on RaspberryPi)
(Rich Neswold)
- GPR#335: Type error messages specify if a type is abstract
because no corresponding cmi could be found. (Hugo Heuzard)
- GPR#365: prevent printing just a single type variable on one side
of a type error clash. (Hugo Heuzard)
- GPR#383: configure: define _ALL_SOURCE for build on AIX7.1
(tkob)
- GPR#401: automatically retry failed test directories in the testsuite
(David Allsopp)
Build system:
- GPR#388: FlexDLL added as a Git submodule and bootstrappable with the compiler
(David Allsopp)
OCaml 4.02.3 (27 Jul 2015):
---------------------------

21
Makefile
View File

@ -252,6 +252,10 @@ installopt:
cd asmrun; $(MAKE) install
cp ocamlopt $(INSTALL_BINDIR)/ocamlopt$(EXE)
cd stdlib; $(MAKE) installopt
cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \
$(INSTALL_COMPLIBDIR)
cp middle_end/base_types/*.cmi middle_end/base_types/*.cmt \
middle_end/base_types/*.cmti $(INSTALL_COMPLIBDIR)
cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti $(INSTALL_COMPLIBDIR)
cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR)
if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) installopt); \
@ -314,8 +318,9 @@ ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART)
# The native-code compiler
compilerlibs/ocamloptcomp.cma: $(ASMCOMP)
$(CAMLC) -a -o $@ $(ASMCOMP)
compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP)
$(CAMLC) -a -o $@ $(MIDDLE_END) $(ASMCOMP)
partialclean::
rm -f compilerlibs/ocamloptcomp.cma
@ -414,6 +419,7 @@ utils/config.ml: utils/config.mlp config/Makefile
-e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
-e 's|%%HOST%%|$(HOST)|' \
-e 's|%%TARGET%%|$(TARGET)|' \
-e 's|%%FLAMBDA%%|$(FLAMBDA)|' \
utils/config.mlp > utils/config.ml
partialclean::
@ -466,8 +472,8 @@ partialclean::
# The native-code compiler compiled with itself
compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx)
$(CAMLOPT) -a -o $@ $(ASMCOMP:.cmo=.cmx)
compilerlibs/ocamloptcomp.cmxa: $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx)
$(CAMLOPT) -a -o $@ $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx)
partialclean::
rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a
@ -480,7 +486,7 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
partialclean::
rm -f ocamlopt.opt
$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt
$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt
# The numeric opcodes
@ -780,12 +786,13 @@ clean::
$(CAMLOPT) $(COMPFLAGS) -c $<
partialclean::
for d in utils parsing typing bytecomp asmcomp driver toplevel tools; \
for d in utils parsing typing bytecomp asmcomp middle_end middle_end/base_types driver toplevel tools; \
do rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.[so] $$d/*~; done
rm -f *~
depend: beforedepend
(for d in utils parsing typing bytecomp asmcomp driver toplevel; \
(for d in utils parsing typing bytecomp asmcomp middle_end \
middle_end/base_types driver toplevel; \
do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \
done) > .depend

96
Makefile.nt
View File

@ -18,6 +18,48 @@ include Makefile.shared
defaultentry:
@echo "Please refer to the installation instructions in file README.win32.adoc."
FLEXDLL_SUBMODULE_PRESENT:=$(wildcard flexdll/Makefile)
BOOT_FLEXLINK_CMD=$(if $(FLEXDLL_SUBMODULE_PRESENT),FLEXLINK_CMD="../boot/ocamlrun ../flexdll/flexlink.exe")
CAMLOPT:=$(if $(FLEXDLL_SUBMODULE_PRESENT),OCAML_FLEXLINK="boot/ocamlrun flexdll/flexlink.exe") $(CAMLOPT)
# FlexDLL sources missing error messages
# Different git mechanism displayed depending on whether this source tree came
# from a git clone or a source tarball.
# Displayed in all cases
flexdll-common-err:
@echo In order to bootstrap FlexDLL, you need to place the sources in flexdll
@echo This can either be done by downloading a source tarball from
@echo \ http://alain.frisch.fr/flexdll.html
flexdll/Makefile: $(if $(wildcard flexdll/Makefile),,$(if $(wildcard .git),flexdll-common-err,flexdll-repo))
@echo or by checking out the flexdll submodule with
@echo \ git submodule update --init
@false
flexdll-repo: flexdll-common-err
@echo or by cloning the git repository
@echo \ git clone https://github.com/alainfrisch/flexdll.git
@echo
@false
# Bootstrapping FlexDLL - leaves a bytecode image of flexlink.exe in flexdll/
flexdll: flexdll/Makefile
cd byterun ; $(MAKEREC) BOOTSTRAPPING_FLEXLINK=yes ocamlrun$(EXE)
cp byterun/ocamlrun.exe boot/ocamlrun.exe
cd stdlib ; $(MAKEREC) COMPILER=../boot/ocamlc stdlib.cma std_exit.cmo
cd stdlib ; cp stdlib.cma std_exit.cmo *.cmi ../boot
cd flexdll ; $(MAKECMD) MSVC_DETECT=0 TOOLCHAIN=$(TOOLCHAIN) TOOLPREF=$(TOOLPREF) CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false OCAMLOPT="../boot/ocamlrun ../boot/ocamlc -I ../boot" flexlink.exe support
cd byterun ; $(MAKEREC) clean
$(MAKEREC) partialclean
flexlink.opt:
cd flexdll ; \
mv flexlink.exe flexlink ; \
$(MAKECMD) OCAML_FLEXLINK="../boot/ocamlrun ./flexlink" MSVC_DETECT=0 TOOLCHAIN=$(TOOLCHAIN) TOOLPREF=$(TOOLPREF) OCAMLOPT="../ocamlopt.opt -I ../stdlib" flexlink.exe ; \
mv flexlink.exe flexlink.opt ; \
mv flexlink flexlink.exe
# Recompile the system using the bootstrap compiler
all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \
otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \
@ -60,11 +102,11 @@ LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader
# Start up the system from the distribution compiler
coldstart:
cd byterun ; $(MAKEREC) all
cd byterun ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
cp byterun/ocamlrun.exe boot/ocamlrun.exe
cd yacc ; $(MAKEREC) all
cd yacc ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
cp yacc/ocamlyacc.exe boot/ocamlyacc.exe
cd stdlib ; $(MAKEREC) COMPILER=../boot/ocamlc all
cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) COMPILER=../boot/ocamlc all
cd stdlib ; cp $(LIBFILES) ../boot
# Build the core system: the minimum needed to make depend and bootstrap
@ -126,8 +168,10 @@ opt:
$(MAKEREC) otherlibrariesopt ocamltoolsopt
# Native-code versions of the tools
# If the submodule is initialised, then opt.opt will build a native flexlink
opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \
ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT)
ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLBUILDNATIVE) \
$(OCAMLDOC_OPT) $(if $(wildcard flexdll/Makefile),flexlink.opt)
# Complete build using fast compilers
world.opt: coldstart opt.opt
@ -177,17 +221,29 @@ installbyt:
else :; fi
if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) install); \
else :; fi
if test -n "$(FLEXDLL_SUBMODULE_PRESENT)"; then $(MAKEREC) install-flexdll; \
else :; fi
cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config
cp README.adoc $(INSTALL_DISTRIB)/Readme.general.txt
cp README.win32.adoc $(INSTALL_DISTRIB)/Readme.windows.txt
cp LICENSE $(INSTALL_DISTRIB)/License.txt
cp Changes $(INSTALL_DISTRIB)/Changes.txt
install-flexdll:
# The $(if ...) installs the correct .manifest file for MSVC and MSVC64
# (GNU make doesn't have ifeq as a function, hence slightly convoluted use of filter-out)
cp flexdll/flexlink.exe $(if $(filter-out mingw,$(TOOLCHAIN)),flexdll/default$(filter-out _i386,_$(ARCH)).manifest) $(INSTALL_BINDIR)/
cp flexdll/flexdll_*.$(O) $(INSTALL_LIBDIR)
# Installation of the native-code compiler
installopt:
cd asmrun ; $(MAKEREC) install
cp ocamlopt $(INSTALL_BINDIR)/ocamlopt.exe
cd stdlib ; $(MAKEREC) installopt
cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \
$(INSTALL_COMPLIBDIR)
cp middle_end/base_types/*.cmi middle_end/base_types/*.cmt \
middle_end/base_types/*.cmti $(INSTALL_COMPLIBDIR)
cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti $(INSTALL_COMPLIBDIR)
cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR)
if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) installopt); fi
@ -198,6 +254,7 @@ installopt:
done
if test -f ocamlopt.opt ; then $(MAKEREC) installoptopt; fi
cd tools; $(MAKEREC) installopt
if test -f ocamlopt.opt -a -f flexdll/flexlink.opt ; then cp -f flexdll/flexlink.opt $(INSTALL_BINDIR)/flexlink.exe ; fi
installoptopt:
cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE)
@ -237,8 +294,8 @@ partialclean::
# The native-code compiler
compilerlibs/ocamloptcomp.cma: $(ASMCOMP)
$(CAMLC) -a -o $@ $(ASMCOMP)
compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP)
$(CAMLC) -a -o $@ $(MIDDLE_END) $(ASMCOMP)
partialclean::
rm -f compilerlibs/ocamloptcomp.cma
@ -313,6 +370,8 @@ utils/config.ml: utils/config.mlp config/Makefile
-e 's|%%CC_PROFILE%%||' \
-e 's|%%HOST%%|$(HOST)|' \
-e 's|%%TARGET%%|$(TARGET)|' \
-e 's|%%FLAMBDA%%|$(FLAMBDA)|' \
-e 's|%%FLEXLINK_FLAGS%%|$(FLEXLINK_FLAGS)|' \
utils/config.mlp > utils/config.ml
partialclean::
@ -365,8 +424,8 @@ partialclean::
# The native-code compiler compiled with itself
compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx)
$(CAMLOPT) -a -o $@ $(ASMCOMP:.cmo=.cmx)
compilerlibs/ocamloptcomp.cmxa: $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx)
$(CAMLOPT) -a -o $@ $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx)
partialclean::
rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A)
@ -379,7 +438,7 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
partialclean::
rm -f ocamlopt.opt
$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt
$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt
# The numeric opcodes
@ -489,7 +548,7 @@ partialclean::
runtime: makeruntime stdlib/libcamlrun.$(A)
makeruntime:
cd byterun ; $(MAKEREC) all
cd byterun ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
stdlib/libcamlrun.$(A): byterun/libcamlrun.$(A)
cp byterun/libcamlrun.$(A) stdlib/libcamlrun.$(A)
clean::
@ -515,11 +574,11 @@ alldepend::
# The library
library:
cd stdlib ; $(MAKEREC) all
cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
library-cross:
cd stdlib ; $(MAKEREC) CAMLRUN=../byterun/ocamlrun all
cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) CAMLRUN=../byterun/ocamlrun all
libraryopt:
cd stdlib ; $(MAKEREC) allopt
cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) allopt
partialclean::
cd stdlib ; $(MAKEREC) clean
alldepend::
@ -537,7 +596,7 @@ alldepend::
cd lex ; $(MAKEREC) depend
ocamlyacc:
cd yacc ; $(MAKEREC) all
cd yacc ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
clean::
cd yacc ; $(MAKEREC) clean
@ -608,7 +667,7 @@ ocamlbuild.byte: ocamlc otherlibraries
cd ocamlbuild && $(MAKE) all
ocamlbuild.native: ocamlopt otherlibrariesopt
cd ocamlbuild && $(MAKE) allopt
cd ocamlbuild && $(if $(FLEXDLL_SUBMODULE_PRESENT),OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe") $(MAKE) allopt
partialclean::
cd ocamlbuild && $(MAKE) clean
@ -640,12 +699,16 @@ partialclean::
rm -f typing/*.cm* typing/*.$(O) typing/*.$(S)
rm -f bytecomp/*.cm* bytecomp/*.$(O) bytecomp/*.$(S)
rm -f asmcomp/*.cm* asmcomp/*.$(O) asmcomp/*.$(S)
rm -f middle_end/*.cm* middle_end/*.$(O) middle_end/*.$(S)
rm -f middle_end/base_types/*.cm* middle_end/base_types/*.$(O) \
middle_end/base_types/*.$(S)
rm -f driver/*.cm* driver/*.$(O) driver/*.$(S)
rm -f toplevel/*.cm* toplevel/*.$(O) toplevel/*.$(S)
rm -f tools/*.cm* tools/*.$(O) tools/*.$(S)
depend: beforedepend
(for d in utils parsing typing bytecomp asmcomp driver toplevel; \
(for d in utils parsing typing bytecomp asmcomp middle_end \
middle_end/base_types driver toplevel; \
do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \
done) > .depend
@ -671,5 +734,6 @@ distclean:
.PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries
.PHONY: otherlibrariesopt promote promote-cross
.PHONY: restore runtime runtimeopt makeruntimeopt world world.opt
.PHONY: flexdll flexlink.opt flexdll-common-err flexdll-repo
include .depend

82
Makefile.shared
View File

@ -20,7 +20,7 @@ include stdlib/StdlibModules
CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot
CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
COMPFLAGS=-strict-sequence -principal -w +33..39+48+50 -warn-error A -bin-annot \
-safe-string $(INCLUDES)
-safe-string -strict-formats $(INCLUDES)
LINKFLAGS=
YACCFLAGS=-v
@ -33,13 +33,12 @@ OCAMLBUILDNATIVE=$(WITH_OCAMLBUILD:=.native)
OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt)
INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
-I toplevel
INCLUDES=-I utils -I parsing -I typing -I bytecomp -I middle_end \
-I middle_end/base_types -I asmcomp -I driver -I toplevel
UTILS=utils/config.cmo utils/clflags.cmo \
utils/misc.cmo \
utils/identifiable.cmo utils/numbers.cmo \
utils/tbl.cmo utils/timings.cmo \
UTILS=utils/config.cmo utils/misc.cmo \
utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
utils/clflags.cmo utils/tbl.cmo utils/timings.cmo \
utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
utils/consistbl.cmo \
utils/strongly_connected_components.cmo
@ -49,8 +48,8 @@ PARSING=parsing/location.cmo parsing/longident.cmo \
parsing/syntaxerr.cmo parsing/parser.cmo \
parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
parsing/pprintast.cmo \
parsing/ast_mapper.cmo parsing/attr_helper.cmo \
parsing/builtin_attributes.cmo
parsing/ast_mapper.cmo parsing/ast_iterator.cmo parsing/attr_helper.cmo \
parsing/builtin_attributes.cmo parsing/ast_invariants.cmo
TYPING=typing/ident.cmo typing/path.cmo \
typing/primitive.cmo typing/types.cmo \
@ -105,8 +104,17 @@ ASMCOMP=\
asmcomp/arch.cmo \
asmcomp/cmm.cmo asmcomp/printcmm.cmo \
asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \
asmcomp/closure.cmo asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \
asmcomp/clambda.cmo asmcomp/printclambda.cmo \
asmcomp/export_info.cmo \
asmcomp/export_info_for_pack.cmo \
asmcomp/compilenv.cmo \
asmcomp/closure.cmo \
asmcomp/build_export_info.cmo \
asmcomp/closure_offsets.cmo \
asmcomp/flambda_to_clambda.cmo \
asmcomp/import_approx.cmo \
asmcomp/un_anf.cmo \
asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \
asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
asmcomp/comballoc.cmo \
asmcomp/CSEgen.cmo asmcomp/CSE.cmo \
@ -123,6 +131,58 @@ ASMCOMP=\
asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \
driver/opterrors.cmo driver/optcompile.cmo
MIDDLE_END=\
middle_end/base_types/tag.cmo \
middle_end/base_types/linkage_name.cmo \
middle_end/base_types/compilation_unit.cmo \
middle_end/base_types/variable.cmo \
middle_end/base_types/mutable_variable.cmo \
middle_end/base_types/id_types.cmo \
middle_end/base_types/set_of_closures_id.cmo \
middle_end/base_types/closure_element.cmo \
middle_end/base_types/closure_id.cmo \
middle_end/base_types/var_within_closure.cmo \
middle_end/base_types/static_exception.cmo \
middle_end/base_types/export_id.cmo \
middle_end/base_types/symbol.cmo \
middle_end/semantics_of_primitives.cmo \
middle_end/allocated_const.cmo \
middle_end/flambda.cmo \
middle_end/flambda_iterators.cmo \
middle_end/flambda_utils.cmo \
middle_end/inlining_cost.cmo \
middle_end/effect_analysis.cmo \
middle_end/freshening.cmo \
middle_end/simple_value_approx.cmo \
middle_end/lift_code.cmo \
middle_end/closure_conversion_aux.cmo \
middle_end/closure_conversion.cmo \
middle_end/initialize_symbol_to_let_symbol.cmo \
middle_end/lift_let_to_initialize_symbol.cmo \
middle_end/find_recursive_functions.cmo \
middle_end/invariant_params.cmo \
middle_end/inconstant_idents.cmo \
middle_end/alias_analysis.cmo \
middle_end/lift_constants.cmo \
middle_end/share_constants.cmo \
middle_end/simplify_common.cmo \
middle_end/remove_unused_arguments.cmo \
middle_end/remove_unused_closure_vars.cmo \
middle_end/remove_unused_program_constructs.cmo \
middle_end/simplify_boxed_integer_ops.cmo \
middle_end/simplify_primitives.cmo \
middle_end/inlining_stats_types.cmo \
middle_end/inlining_stats.cmo \
middle_end/inline_and_simplify_aux.cmo \
middle_end/augment_closures.cmo \
middle_end/unbox_closures.cmo \
middle_end/inlining_transforms.cmo \
middle_end/inlining_decision.cmo \
middle_end/inline_and_simplify.cmo \
middle_end/ref_to_variables.cmo \
middle_end/flambda_invariants.cmo \
middle_end/middle_end.cmo
TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \
toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo

122
asmcomp/asmgen.ml
View File

@ -12,6 +12,8 @@
(* From lambda to assembly code *)
[@@@ocaml.warning "+a-4-9-40-41-42"]
open Format
open Config
open Clflags
@ -35,8 +37,39 @@ let pass_dump_linear_if ppf flag message phrase =
if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase;
phrase
let clambda_dump_if ppf ulambda =
if !dump_clambda then Printclambda.clambda ppf ulambda; ulambda
let flambda_raw_clambda_dump_if ppf
({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _;
structured_constants; exported = _; } as input) =
if !dump_rawclambda then
begin
Format.fprintf ppf "@.clambda (before Un_anf):@.";
Printclambda.clambda ppf ulambda;
Symbol.Map.iter (fun sym cst ->
Format.fprintf ppf "%a:@ %a@."
Symbol.print sym
Printclambda.structured_constant cst)
structured_constants
end;
if !dump_cmm then Format.fprintf ppf "@.cmm:@.";
input
type clambda_and_constants =
Clambda.ulambda *
Clambda.preallocated_block list *
Clambda.preallocated_constant list
let raw_clambda_dump_if ppf ((ulambda, _, structured_constants):clambda_and_constants) =
if !dump_rawclambda then
begin
Format.fprintf ppf "@.clambda (before Un_anf):@.";
Printclambda.clambda ppf ulambda;
List.iter (fun {Clambda.symbol; definition} ->
Format.fprintf ppf "%s:@ %a@."
symbol
Printclambda.structured_constant definition)
structured_constants
end;
if !dump_cmm then Format.fprintf ppf "@.cmm:@."
let rec regalloc ppf round fd =
if round > 50 then
@ -100,7 +133,8 @@ let compile_genfuns ppf f =
| _ -> ())
(Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
let compile_unit ~source_provenance asm_filename keep_asm obj_filename gen =
let compile_unit ~source_provenance _output_prefix asm_filename keep_asm
obj_filename gen =
let create_asm = keep_asm || not !Emitaux.binary_backend_available in
Emitaux.create_asm_file := create_asm;
try
@ -124,20 +158,15 @@ let compile_unit ~source_provenance asm_filename keep_asm obj_filename gen =
remove_file obj_filename;
raise exn
let gen_implementation ?toplevel ~source_provenance ppf (size, lam) =
let main_module_block =
{
Clambda.symbol = Compilenv.make_symbol None;
exported = true;
tag = 0;
size;
}
in
let set_export_info (ulambda, prealloc, structured_constants, export) =
Compilenv.set_export_info export;
(ulambda, prealloc, structured_constants)
let end_gen_implementation ?toplevel ~source_provenance ppf
(clambda:clambda_and_constants) =
Emit.begin_assembly ();
Timings.(time (Clambda source_provenance)) (Closure.intro size) lam
++ clambda_dump_if ppf
++ Timings.(time (Cmm source_provenance))
(fun clam -> Cmmgen.compunit (clam, [main_module_block], []))
clambda
++ Timings.(time (Cmm source_provenance)) Cmmgen.compunit
++ Timings.(time (Compile_phrases source_provenance))
(List.iter (compile_phrase ppf))
++ (fun () -> ());
@ -156,14 +185,69 @@ let gen_implementation ?toplevel ~source_provenance ppf (size, lam) =
);
Emit.end_assembly ()
let compile_implementation ?toplevel ~source_provenance prefixname ppf (size, lam) =
let flambda_gen_implementation ?toplevel ~source_provenance ~backend ppf
(program:Flambda.program) =
let export = Build_export_info.build_export_info ~backend program in
let (clambda, preallocated, constants) =
Timings.time (Flambda_pass ("backend", source_provenance)) (fun () ->
(program, export)
++ Flambda_to_clambda.convert
++ flambda_raw_clambda_dump_if ppf
++ (fun { Flambda_to_clambda. expr; preallocated_blocks;
structured_constants; exported; } ->
(* "init_code" following the name used in
[Cmmgen.compunit_and_constants]. *)
Un_anf.apply expr ~what:"init_code", preallocated_blocks,
structured_constants, exported)
++ set_export_info) ()
in
let constants =
List.map (fun (symbol, definition) ->
{ Clambda.symbol = Linkage_name.to_string (Symbol.label symbol);
exported = true;
definition })
(Symbol.Map.bindings constants)
in
end_gen_implementation ?toplevel ~source_provenance ppf
(clambda, preallocated, constants)
let lambda_gen_implementation ?toplevel ~source_provenance ppf
(lambda:Lambda.program) =
let clambda = Closure.intro lambda.main_module_block_size lambda.code in
let preallocated_block =
Clambda.{
symbol = Compilenv.make_symbol None;
exported = true;
tag = 0;
size = lambda.main_module_block_size;
}
in
let clambda_and_constants =
clambda, [preallocated_block], []
in
raw_clambda_dump_if ppf clambda_and_constants;
end_gen_implementation ?toplevel ~source_provenance ppf clambda_and_constants
let compile_implementation_gen ?toplevel ~source_provenance prefixname
ppf gen_implementation program =
let asmfile =
if !keep_asm_file || !Emitaux.binary_backend_available
then prefixname ^ ext_asm
else Filename.temp_file "camlasm" ext_asm
in
compile_unit ~source_provenance asmfile !keep_asm_file (prefixname ^ ext_obj)
(fun () -> gen_implementation ?toplevel ~source_provenance ppf (size, lam))
compile_unit ~source_provenance prefixname asmfile !keep_asm_file
(prefixname ^ ext_obj) (fun () ->
gen_implementation ?toplevel ~source_provenance ppf program)
let compile_implementation_clambda ?toplevel ~source_provenance prefixname
ppf (program:Lambda.program) =
compile_implementation_gen ?toplevel ~source_provenance prefixname
ppf lambda_gen_implementation program
let compile_implementation_flambda ?toplevel ~source_provenance prefixname
~backend ppf (program:Flambda.program) =
compile_implementation_gen ?toplevel ~source_provenance prefixname
ppf (flambda_gen_implementation ~backend) program
(* Error report *)

14
asmcomp/asmgen.mli
View File

@ -12,10 +12,19 @@
(* From lambda to assembly code *)
val compile_implementation :
val compile_implementation_flambda :
?toplevel:(string -> bool) ->
source_provenance:Timings.source_provenance ->
string -> Format.formatter -> int * Lambda.lambda -> unit
string ->
backend:(module Backend_intf.S) ->
Format.formatter -> Flambda.program -> unit
val compile_implementation_clambda :
?toplevel:(string -> bool) ->
source_provenance:Timings.source_provenance ->
string ->
Format.formatter -> Lambda.program -> unit
val compile_phrase :
Format.formatter -> Cmm.phrase -> unit
@ -26,5 +35,6 @@ val report_error: Format.formatter -> error -> unit
val compile_unit:
source_provenance:Timings.source_provenance ->
string(*prefixname*) ->
string(*asm file*) -> bool(*keep asm*) ->
string(*obj file*) -> (unit -> unit) -> unit

8
asmcomp/asmlibrarian.ml
View File

@ -22,6 +22,12 @@ type error =
exception Error of error
let default_ui_export_info =
if Config.flambda then
Cmx_format.Flambda Export_info.empty
else
Cmx_format.Clambda Clambda.Value_unknown
let read_info name =
let filename =
try
@ -34,7 +40,7 @@ let read_info name =
since the compiler will go looking directly for .cmx files.
The linker, which is the only one that reads .cmxa files, does not
need the approximation. *)
info.ui_approx <- Clambda.Value_unknown;
info.ui_export_info <- default_ui_export_info;
(Filename.chop_suffix filename ".cmx" ^ ext_obj, (info, crc))
let create_archive file_list lib_name =

4
asmcomp/asmlink.ml
View File

@ -268,7 +268,7 @@ let link_shared ppf objfiles output_name =
then output_name ^ ".startup" ^ ext_asm
else Filename.temp_file "camlstartup" ext_asm in
let startup_obj = output_name ^ ".startup" ^ ext_obj in
Asmgen.compile_unit ~source_provenance:Timings.Startup
Asmgen.compile_unit ~source_provenance:Timings.Startup output_name
startup !Clflags.keep_startup_file startup_obj
(fun () ->
make_shared_startup_file ppf
@ -327,7 +327,7 @@ let link ppf objfiles output_name =
then output_name ^ ".startup" ^ ext_asm
else Filename.temp_file "camlstartup" ext_asm in
let startup_obj = Filename.temp_file "camlstartup" ext_obj in
Asmgen.compile_unit ~source_provenance:Timings.Startup
Asmgen.compile_unit ~source_provenance:Timings.Startup output_name
startup !Clflags.keep_startup_file startup_obj
(fun () -> make_startup_file ppf units_tolink);
Misc.try_finally

89
asmcomp/asmpackager.ml
View File

@ -75,7 +75,8 @@ let check_units members =
(* Make the .o file for the package *)
let make_package_object ppf members targetobj targetname coercion =
let make_package_object ppf members targetobj targetname coercion
~backend =
let objtemp =
if !Clflags.keep_asm_file
then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj
@ -91,10 +92,32 @@ let make_package_object ppf members targetobj targetname coercion =
| PM_intf -> None
| PM_impl _ -> Some(Ident.create_persistent m.pm_name))
members in
Asmgen.compile_implementation ~source_provenance:(Timings.Pack targetname)
(chop_extension_if_any objtemp) ppf
(Translmod.transl_store_package
components (Ident.create_persistent targetname) coercion);
let module_ident = Ident.create_persistent targetname in
let source_provenance = Timings.Pack targetname in
let prefixname = chop_extension_if_any objtemp in
if Config.flambda then begin
let size, lam =
Translmod.transl_package_flambda
components module_ident coercion
in
let flam =
Middle_end.middle_end ppf
~source_provenance
~prefixname
~backend
~size
~module_ident
~module_initializer:lam
in
Asmgen.compile_implementation_flambda ~source_provenance
prefixname ~backend ppf flam;
end else begin
let main_module_block_size, code =
Translmod.transl_store_package
components (Ident.create_persistent targetname) coercion in
Asmgen.compile_implementation_clambda ~source_provenance
prefixname ppf { Lambda.code; main_module_block_size; }
end;
let objfiles =
List.map
(fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj)
@ -107,6 +130,18 @@ let make_package_object ppf members targetobj targetname coercion =
(* Make the .cmx file for the package *)
let get_export_info ui =
assert(Config.flambda);
match ui.ui_export_info with
| Clambda _ -> assert false
| Flambda info -> info
let get_approx ui =
assert(not Config.flambda);
match ui.ui_export_info with
| Flambda _ -> assert false
| Clambda info -> info
let build_package_cmx members cmxfile =
let unit_names =
List.map (fun m -> m.pm_name) members in
@ -122,7 +157,42 @@ let build_package_cmx members cmxfile =
(fun m accu ->
match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu)
members [] in
let pack_units =
List.fold_left
(fun set info ->
let unit_id = Compilenv.unit_id_from_name info.ui_name in
Compilation_unit.Set.add
(Compilenv.unit_for_global unit_id) set)
Compilation_unit.Set.empty units in
let units =
if Config.flambda then
List.map (fun info ->
{ info with
ui_export_info =
Flambda
(Export_info_for_pack.import_for_pack ~pack_units
~pack:(Compilenv.current_unit ())
(get_export_info info)) })
units
else
units
in
let ui = Compilenv.current_unit_infos() in
let ui_export_info =
if Config.flambda then
let ui_export_info =
List.fold_left (fun acc info ->
Export_info.merge acc (get_export_info info))
(Export_info_for_pack.import_for_pack ~pack_units
~pack:(Compilenv.current_unit ())
(get_export_info ui))
units
in
Flambda ui_export_info
else
Clambda (get_approx ui)
in
Export_info_for_pack.clear_import_state ();
let pkg_infos =
{ ui_name = ui.ui_name;
ui_symbol = ui.ui_symbol;
@ -134,7 +204,6 @@ let build_package_cmx members cmxfile =
filter(Asmlink.extract_crc_interfaces());
ui_imports_cmx =
filter(Asmlink.extract_crc_implementations());
ui_approx = ui.ui_approx;
ui_curry_fun =
union(List.map (fun info -> info.ui_curry_fun) units);
ui_apply_fun =
@ -143,25 +212,26 @@ let build_package_cmx members cmxfile =
union(List.map (fun info -> info.ui_send_fun) units);
ui_force_link =
List.exists (fun info -> info.ui_force_link) units;
ui_export_info;
} in
Compilenv.write_unit_info pkg_infos cmxfile
(* Make the .cmx and the .o for the package *)
let package_object_files ppf files targetcmx
targetobj targetname coercion =
targetobj targetname coercion ~backend =
let pack_path =
match !Clflags.for_package with
| None -> targetname
| Some p -> p ^ "." ^ targetname in
let members = map_left_right (read_member_info pack_path) files in
check_units members;
make_package_object ppf members targetobj targetname coercion;
make_package_object ppf members targetobj targetname coercion ~backend;
build_package_cmx members targetcmx
(* The entry point *)
let package_files ppf initial_env files targetcmx =
let package_files ppf initial_env files targetcmx ~backend =
let files =
List.map
(fun f ->
@ -181,6 +251,7 @@ let package_files ppf initial_env files targetcmx =
let coercion =
Typemod.package_units initial_env files targetcmi targetname in
package_object_files ppf files targetcmx targetobj targetname coercion
~backend
with x ->
remove_file targetcmx; remove_file targetobj;
raise x

8
asmcomp/asmpackager.mli
View File

@ -13,7 +13,13 @@
(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
original compilation units as sub-modules. *)
val package_files: Format.formatter -> Env.t -> string list -> string -> unit
val package_files
: Format.formatter
-> Env.t
-> string list
-> string
-> backend:(module Backend_intf.S)
-> unit
type error =
Illegal_renaming of string * string * string

10
asmcomp/build_export_info.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
module Env : sig
type t
@ -494,12 +496,6 @@ let build_export_info ~(backend : (module Backend_intf.S))
let _global_symbol, env =
describe_program (Env.Global.create_empty ()) program
in
let globals =
let root_approx : Export_info.approx =
Value_symbol (Compilenv.current_unit_symbol ())
in
Ident.Map.singleton (Compilenv.current_unit_id ()) root_approx
in
let sets_of_closures =
Flambda_utils.all_function_decls_indexed_by_set_of_closures_id program
in
@ -540,7 +536,7 @@ let build_export_info ~(backend : (module Backend_intf.S))
let values =
Export_info.nest_eid_map unnested_values
in
Export_info.create ~values ~globals
Export_info.create ~values
~symbol_id:(Env.Global.symbol_to_export_id_map env)
~offset_fun:Closure_id.Map.empty
~offset_fv:Var_within_closure.Map.empty

2
asmcomp/build_export_info.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
(** Construct export information, for emission into .cmx files, from an
Flambda program. *)

9
asmcomp/closure.ml
View File

@ -119,7 +119,7 @@ let prim_size prim args =
| Praise _ -> 4
| Pstringlength -> 5
| Pstringrefs | Pstringsets -> 6
| Pmakearray kind -> 5 + List.length args
| Pmakearray _ -> 5 + List.length args
| Parraylength kind -> if kind = Pgenarray then 6 else 2
| Parrayrefu kind -> if kind = Pgenarray then 12 else 2
| Parraysetu kind -> if kind = Pgenarray then 16 else 4
@ -1160,7 +1160,12 @@ and close_functions fenv cenv fun_defs =
in
let threshold =
match inline_attribute with
| Default_inline -> !Clflags.inline_threshold + n
| Default_inline ->
let inline_threshold =
Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold
in
let magic_scale_constant = 8. in
int_of_float (inline_threshold *. magic_scale_constant) + n
| Always_inline -> max_int
| Never_inline -> min_int
in

2
asmcomp/closure_offsets.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
type result = {
function_offsets : int Closure_id.Map.t;
free_variable_offsets : int Var_within_closure.Map.t;

2
asmcomp/closure_offsets.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
(** Assign numerical offsets, within closure blocks, for code pointers and
environment entries. *)

102
asmcomp/cmmgen.ml
View File

@ -434,12 +434,6 @@ let safe_mod_bi =
let test_bool = function
Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
| Cop(Clsl, [c; Cconst_int 1]) -> c
| Cconst_int n ->
if n = 1 then
Cconst_int 0
else
Cconst_int 1
| c -> Cop(Ccmpi Cne, [c; Cconst_int 1])
(* Float *)
@ -699,9 +693,9 @@ let rec expr_size env = function
expr_size env body
| 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)
| Uprim(Pmakearray(Pfloatarray), args, _) ->
| Uprim(Pmakearray(Pfloatarray, _), args, _) ->
RHS_floatblock (List.length args)
| Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) ->
RHS_block sz
@ -709,6 +703,10 @@ let rec expr_size env = function
RHS_block (sz + 1)
| Uprim (Pduprecord (Record_float, sz), _, _) ->
RHS_floatblock sz
| Uprim (Pccall { prim_name; _ }, closure::_, _)
when prim_name = "caml_check_value_is_closure" ->
(* Used for "-clambda-checks". *)
expr_size env closure
| Usequence(exp, exp') ->
expr_size env exp'
| _ -> RHS_nonrec
@ -1516,19 +1514,27 @@ let rec transl env e =
make_alloc tag (List.map (transl env) args)
| (Pccall prim, args) ->
transl_ccall env prim args dbg
| (Pmakearray kind, []) ->
| (Pduparray (kind, _), [Uprim (Pmakearray (kind', _), args, _dbg)]) ->
(* We arrive here in two cases:
1. When using Closure, all the time.
2. When using Flambda, if a float array longer than
[Translcore.use_dup_for_constant_arrays_bigger_than] turns out
to be non-constant.
If for some reason Flambda fails to lift a constant array we
could in theory also end up here.
Note that [kind] above is unconstrained, but with the current
state of [Translcore], we will in fact only get here with
[Pfloatarray]s. *)
assert (kind = kind');
transl_make_array env kind args
| (Pduparray _, [arg]) ->
let prim_obj_dup =
Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
in
transl_ccall env prim_obj_dup [arg] dbg
| (Pmakearray (kind, _), []) ->
transl_structured_constant (Uconst_block(0, []))
| (Pmakearray kind, args) ->
begin match kind with
Pgenarray ->
Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none),
[make_alloc 0 (List.map (transl env) args)])
| Paddrarray | Pintarray ->
make_alloc 0 (List.map (transl env) args)
| Pfloatarray ->
make_float_alloc Obj.double_array_tag
(List.map (transl_unbox_float env) args)
end
| (Pmakearray (kind, _), args) -> transl_make_array env kind args
| (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
let elt =
bigarray_get unsafe elt_kind layout
@ -1678,6 +1684,17 @@ let rec transl env e =
| Uunreachable ->
Cop(Cload Word_int, [Cconst_int 0])
and transl_make_array env kind args =
match kind with
| Pgenarray ->
Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none),
[make_alloc 0 (List.map (transl env) args)])
| Paddrarray | Pintarray ->
make_alloc 0 (List.map (transl env) args)
| Pfloatarray ->
make_float_alloc Obj.double_array_tag
(List.map (transl_unbox_float env) args)
and transl_ccall env prim args dbg =
let transl_arg native_repr arg =
match native_repr with
@ -1815,8 +1832,8 @@ and transl_prim_1 env p arg dbg =
tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false,
Debuginfo.none),
[untag_int (transl env arg)]))
| _ ->
fatal_error "Cmmgen.transl_prim_1"
| prim ->
fatal_errorf "Cmmgen.transl_prim_1: %a" Printlambda.primitive prim
and transl_prim_2 env p arg1 arg2 dbg =
match p with
@ -2087,8 +2104,8 @@ and transl_prim_2 env p arg1 arg2 dbg =
tag_int (Cop(Ccmpi(transl_comparison cmp),
[transl_unbox_int env bi arg1;
transl_unbox_int env bi arg2]))
| _ ->
fatal_error "Cmmgen.transl_prim_2"
| prim ->
fatal_errorf "Cmmgen.transl_prim_2: %a" Printlambda.primitive prim
and transl_prim_3 env p arg1 arg2 arg3 dbg =
match p with
@ -2224,8 +2241,8 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
(Cconst_int 7)) idx
(unaligned_set_64 ba_data idx newval))))))
| _ ->
fatal_error "Cmmgen.transl_prim_3"
| prim ->
fatal_errorf "Cmmgen.transl_prim_3: %a" Printlambda.primitive prim
and transl_unbox_float env = function
Uconst(Uconst_ref(_, Some (Uconst_float f))) -> Cconst_float f
@ -2413,9 +2430,15 @@ and transl_letrec env bindings cont =
(* Translate a function definition *)
let transl_function f =
let body =
if Config.flambda then
Un_anf.apply f.body ~what:f.label
else
f.body
in
Cfunction {fun_name = f.label;
fun_args = List.map (fun id -> (id, typ_val)) f.params;
fun_body = transl empty_env f.body;
fun_body = transl empty_env body;
fun_fast = !Clflags.optimize_for_speed;
fun_dbg = f.dbg; }
@ -2517,9 +2540,21 @@ and emit_boxed_int64_constant n cont =
(* Emit constant closures *)
let emit_constant_closure symb fundecls clos_vars cont =
let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont =
let closure_symbol f =
if Config.flambda then
cdefine_symbol (f.label ^ "_closure", global_symb)
else
[]
in
match fundecls with
[] -> assert false
[] ->
(* This should probably not happen: dead code has normally been
eliminated and a closure cannot be accessed without going through
a [Project_closure], which depends on the function. *)
assert (clos_vars = []);
cdefine_symbol symb @
List.fold_right emit_constant clos_vars cont
| f1 :: remainder ->
let rec emit_others pos = function
[] ->
@ -2527,11 +2562,13 @@ let emit_constant_closure symb fundecls clos_vars cont =
| f2 :: rem ->
if f2.arity = 1 || f2.arity = 0 then
Cint(infix_header pos) ::
(closure_symbol f2) @
Csymbol_address f2.label ::
cint_const f2.arity ::
emit_others (pos + 3) rem
else
Cint(infix_header pos) ::
(closure_symbol f2) @
Csymbol_address(curry_function f2.arity) ::
cint_const f2.arity ::
Csymbol_address f2.label ::
@ -2539,6 +2576,7 @@ let emit_constant_closure symb fundecls clos_vars cont =
Cint(black_closure_header (fundecls_size fundecls
+ List.length clos_vars)) ::
cdefine_symbol symb @
(closure_symbol f1) @
if f1.arity = 1 || f1.arity = 0 then
Csymbol_address f1.label ::
cint_const f1.arity ::
@ -2583,9 +2621,9 @@ let transl_all_functions_and_emit_all_constants cont =
in
aux StringSet.empty cont
(* Build the table of GC roots for toplevel modules *)
(* Build the NULL terminated array of gc roots *)
let emit_module_roots_table ~symbols cont =
let emit_gc_roots_table ~symbols cont =
let table_symbol = Compilenv.make_symbol (Some "gc_roots") in
Cdata(Cglobal_symbol table_symbol ::
Cdefine_symbol table_symbol ::
@ -2621,7 +2659,7 @@ let emit_preallocated_blocks preallocated_blocks cont =
List.map (fun ({ Clambda.symbol }:Clambda.preallocated_block) -> symbol)
preallocated_blocks
in
let c1 = emit_module_roots_table ~symbols cont in
let c1 = emit_gc_roots_table ~symbols cont in
List.fold_left preallocate_block c1 preallocated_blocks
(* Translate a compilation unit *)

35
asmcomp/cmx_format.mli
View File

@ -1,14 +1,21 @@
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
(* *)
(* Copyright 2010 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. *)
(* *)
(***********************************************************************)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2010 Institut National de Recherche en Informatique et *)
(* en Automatique *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(* Format of .cmx, .cmxa and .cmxs files *)
@ -22,6 +29,10 @@
The .cmx file contains these infos (as an externed record) plus a MD5
of these infos *)
type export_info =
| Clambda of Clambda.value_approximation
| Flambda of Export_info.t
type unit_infos =
{ mutable ui_name: string; (* Name of unit implemented *)
mutable ui_symbol: string; (* Prefix for symbols *)
@ -29,10 +40,10 @@ type unit_infos =
mutable ui_imports_cmi:
(string * Digest.t option) list; (* Interfaces imported *)
mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *)
mutable ui_approx: Clambda.value_approximation; (* Approx of the structure*)
mutable ui_curry_fun: int list; (* Currying functions needed *)
mutable ui_apply_fun: int list; (* Apply functions needed *)
mutable ui_send_fun: int list; (* Send functions needed *)
mutable ui_export_info: export_info;
mutable ui_force_link: bool } (* Always linked *)
(* Each .a library has a matching .cmxa file that provides the following

182
asmcomp/compilenv.ml
View File

@ -1,20 +1,28 @@
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 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. *)
(* *)
(***********************************************************************)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2010 Institut National de Recherche en Informatique et *)
(* en Automatique *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(* Compilation environments for compilation units *)
[@@@ocaml.warning "+a-4-9-40-41-42"]
open Config
open Misc
open Clambda
open Cmx_format
type error =
@ -26,6 +34,12 @@ exception Error of error
let global_infos_table =
(Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
let export_infos_table =
(Hashtbl.create 10 : (string, Export_info.t) Hashtbl.t)
let imported_sets_of_closures_table =
(Set_of_closures_id.Tbl.create 10
: Flambda.function_declarations Set_of_closures_id.Tbl.t)
let sourcefile = ref None
@ -54,17 +68,25 @@ let structured_constants = ref structured_constants_empty
let exported_constants = Hashtbl.create 17
let merged_environment = ref Export_info.empty
let default_ui_export_info =
if Config.flambda then
Cmx_format.Flambda Export_info.empty
else
Cmx_format.Clambda Value_unknown
let current_unit =
{ ui_name = "";
ui_symbol = "";
ui_defines = [];
ui_imports_cmi = [];
ui_imports_cmx = [];
ui_approx = Value_unknown;
ui_curry_fun = [];
ui_apply_fun = [];
ui_send_fun = [];
ui_force_link = false }
ui_force_link = false;
ui_export_info = default_ui_export_info }
let symbolname_for_pack pack name =
match pack with
@ -80,9 +102,23 @@ let symbolname_for_pack pack name =
Buffer.add_string b name;
Buffer.contents b
let unit_id_from_name name = Ident.create_persistent name
let concat_symbol unitname id =
unitname ^ "__" ^ id
let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
let prefix = "caml" ^ unitname in
match idopt with
| None -> prefix
| Some id -> concat_symbol prefix id
let current_unit_linkage_name () =
Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None)
let reset ?packname ~source_provenance:file name =
Hashtbl.clear global_infos_table;
Set_of_closures_id.Tbl.clear imported_sets_of_closures_table;
let symbol = symbolname_for_pack packname name in
sourcefile := Some file;
current_unit.ui_name <- name;
@ -95,7 +131,16 @@ let reset ?packname ~source_provenance:file name =
current_unit.ui_send_fun <- [];
current_unit.ui_force_link <- false;
Hashtbl.clear exported_constants;
structured_constants := structured_constants_empty
structured_constants := structured_constants_empty;
current_unit.ui_export_info <- default_ui_export_info;
merged_environment := Export_info.empty;
Hashtbl.clear export_infos_table;
let compilation_unit =
Compilation_unit.create
(Ident.create_persistent name)
(current_unit_linkage_name ())
in
Compilation_unit.set_current compilation_unit
let current_unit_infos () =
current_unit
@ -187,18 +232,26 @@ let cache_unit_info ui =
(* Return the approximation of a global identifier *)
let toplevel_approx = Hashtbl.create 16
let get_clambda_approx ui =
assert(not Config.flambda);
match ui.ui_export_info with
| Flambda _ -> assert false
| Clambda approx -> approx
let record_global_approx_toplevel id =
Hashtbl.add toplevel_approx current_unit.ui_name current_unit.ui_approx
let toplevel_approx :
(string, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16
let record_global_approx_toplevel () =
Hashtbl.add toplevel_approx current_unit.ui_name
(get_clambda_approx current_unit)
let global_approx id =
if Ident.is_predef_exn id then Value_unknown
if Ident.is_predef_exn id then Clambda.Value_unknown
else try Hashtbl.find toplevel_approx (Ident.name id)
with Not_found ->
match get_global_info id with
| None -> Value_unknown
| Some ui -> ui.ui_approx
| None -> Clambda.Value_unknown
| Some ui -> get_clambda_approx ui
(* Return the symbol used to refer to a global identifier *)
@ -217,8 +270,61 @@ let symbol_for_global id =
(* Register the approximation of the module being compiled *)
let unit_for_global id =
let sym_label = Linkage_name.create (symbol_for_global id) in
Compilation_unit.create id sym_label
let predefined_exception_compilation_unit =
Compilation_unit.create (Ident.create_persistent "__dummy__")
(Linkage_name.create "__dummy__")
let is_predefined_exception sym =
Compilation_unit.equal
predefined_exception_compilation_unit
(Symbol.compilation_unit sym)
let symbol_for_global' id =
let sym_label = Linkage_name.create (symbol_for_global id) in
if Ident.is_predef_exn id then
Symbol.unsafe_create predefined_exception_compilation_unit sym_label
else
Symbol.unsafe_create (unit_for_global id) sym_label
let set_global_approx approx =
current_unit.ui_approx <- approx
assert(not Config.flambda);
current_unit.ui_export_info <- Clambda approx
(* Exporting and importing cross module information *)
let get_flambda_export_info ui =
assert(Config.flambda);
match ui.ui_export_info with
| Clambda _ -> assert false
| Flambda ei -> ei
let set_export_info export_info =
assert(Config.flambda);
current_unit.ui_export_info <- Flambda export_info
let approx_for_global comp_unit =
let id = Compilation_unit.get_persistent_ident comp_unit in
if (Compilation_unit.equal
predefined_exception_compilation_unit
comp_unit)
|| Ident.is_predef_exn id
|| not (Ident.global id)
then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id);
let modname = Ident.name id in
try Hashtbl.find export_infos_table modname with
| Not_found ->
let exported = match get_global_info id with
| None -> Export_info.empty
| Some ui -> get_flambda_export_info ui in
Hashtbl.add export_infos_table modname exported;
merged_environment := Export_info.merge !merged_environment exported;
exported
let approx_env () = !merged_environment
(* Record that a currying function or application function is needed *)
@ -227,6 +333,7 @@ let need_curry_fun n =
current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun
let need_apply_fun n =
assert(n > 0);
if not (List.mem n current_unit.ui_apply_fun) then
current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun
@ -249,14 +356,19 @@ let save_unit_info filename =
current_unit.ui_imports_cmi <- Env.imports();
write_unit_info current_unit filename
let current_unit_linkage_name () =
Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None)
let current_unit () =
match Compilation_unit.get_current () with
| Some current_unit -> current_unit
| None -> Misc.fatal_error "Compilenv.current_unit"
let current_unit_symbol () =
Symbol.unsafe_create (current_unit ()) (current_unit_linkage_name ())
let const_label = ref 0
let new_const_label () =
incr const_label;
!const_label
let new_const_symbol () =
incr const_label;
make_symbol (Some (string_of_int !const_label))
@ -302,6 +414,24 @@ let structured_constants () =
})
(!structured_constants).strcst_all
let closure_symbol fv =
let compilation_unit = Closure_id.get_compilation_unit fv in
let unitname =
Linkage_name.to_string (Compilation_unit.get_linkage_name compilation_unit)
in
let linkage_name =
concat_symbol unitname ((Closure_id.unique_name fv) ^ "_closure")
in
Symbol.unsafe_create compilation_unit (Linkage_name.create linkage_name)
let function_label fv =
let compilation_unit = Closure_id.get_compilation_unit fv in
let unitname =
Linkage_name.to_string
(Compilation_unit.get_linkage_name compilation_unit)
in
(concat_symbol unitname (Closure_id.unique_name fv))
(* Error report *)
open Format

97
asmcomp/compilenv.mli
View File

@ -1,34 +1,63 @@
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 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. *)
(* *)
(***********************************************************************)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2010 Institut National de Recherche en Informatique et *)
(* en Automatique *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file ../LICENSE. *)
(* *)
(**************************************************************************)
(* Compilation environments for compilation units *)
open Cmx_format
(* CR-soon mshinwell: this is a bit ugly
mshinwell: deferred CR, this has been addressed in the export info
improvement feature.
*)
val imported_sets_of_closures_table
: Flambda.function_declarations Set_of_closures_id.Tbl.t
(* flambda-only *)
val reset: ?packname:string -> source_provenance:Timings.source_provenance ->
string -> unit
(* Reset the environment and record the name of the unit being
compiled (arg). Optional argument is [-for-pack] prefix. *)
val unit_id_from_name: string -> Ident.t
(* flambda-only *)
val current_unit_infos: unit -> unit_infos
(* Return the infos for the unit being compiled *)
val current_unit_name: unit -> string
(* Return the name of the unit being compiled *)
(* Return the name of the unit being compiled
clambda-only *)
val current_unit_linkage_name: unit -> Linkage_name.t
(* Return the linkage_name of the unit being compiled.
flambda-only *)
val current_build: unit -> Timings.source_provenance
(* Return the kind of build source being compiled. If it is a
file compilation it also provides the filename. *)
val current_unit: unit -> Compilation_unit.t
(* flambda-only *)
val current_unit_symbol: unit -> Symbol.t
(* flambda-only *)
val make_symbol: ?unitname:string -> string option -> string
(* [make_symbol ~unitname:u None] returns the asm symbol that
corresponds to the compilation unit [u] (default: the current unit).
@ -40,16 +69,36 @@ val symbol_in_current_unit: string -> bool
(* Return true if the given asm symbol belongs to the
current compilation unit, false otherwise. *)
val is_predefined_exception: Symbol.t -> bool
(* flambda-only *)
val unit_for_global: Ident.t -> Compilation_unit.t
(* flambda-only *)
val symbol_for_global: Ident.t -> string
(* Return the asm symbol that refers to the given global identifier *)
(* Return the asm symbol that refers to the given global identifier
flambda-only *)
val symbol_for_global': Ident.t -> Symbol.t
(* flambda-only *)
val global_approx: Ident.t -> Clambda.value_approximation
(* Return the approximation for the given global identifier *)
(* Return the approximation for the given global identifier
clambda-only *)
val set_global_approx: Clambda.value_approximation -> unit
(* Record the approximation of the unit being compiled *)
(* Record the approximation of the unit being compiled
clambda-only *)
val record_global_approx_toplevel: unit -> unit
(* Record the current approximation for the current toplevel phrase *)
(* Record the current approximation for the current toplevel phrase
clambda-only *)
val set_export_info: Export_info.t -> unit
(* Record the informations of the unit being compiled
flambda-only *)
val approx_env: unit -> Export_info.t
(* Returns all the information loaded from extenal compilation units
flambda-only *)
val approx_for_global: Compilation_unit.t -> Export_info.t
(* Loads the exported information declaring the compilation_unit
flambda-only *)
val need_curry_fun: int -> unit
val need_apply_fun: int -> unit
@ -58,7 +107,13 @@ val need_send_fun: int -> unit
message sending) function with the given arity *)
val new_const_symbol : unit -> string
val new_const_label : unit -> int
val closure_symbol : Closure_id.t -> Symbol.t
(* Symbol of a function if the function is
closed (statically allocated)
flambda-only *)
val function_label : Closure_id.t -> string
(* linkage name of the code of a function
flambda-only *)
val new_structured_constant:
Clambda.ustructured_constant ->
@ -68,11 +123,13 @@ val structured_constants:
unit -> Clambda.preallocated_constant list
val clear_structured_constants: unit -> unit
val add_exported_constant: string -> unit
(* clambda-only *)
type structured_constants
(* clambda-only *)
val snapshot: unit -> structured_constants
(* clambda-only *)
val backtrack: structured_constants -> unit
(* clambda-only *)
val read_unit_info: string -> unit_infos * Digest.t
(* Read infos and MD5 from a [.cmx] file. *)

12
asmcomp/export_info.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
type value_string_contents =
| Contents of string
| Unknown_or_mutable
@ -133,7 +135,6 @@ type t = {
sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
closures : Flambda.function_declarations Closure_id.Map.t;
values : descr Export_id.Map.t Compilation_unit.Map.t;
globals : approx Ident.Map.t;
symbol_id : Export_id.t Symbol.Map.t;
offset_fun : int Closure_id.Map.t;
offset_fv : int Var_within_closure.Map.t;
@ -145,7 +146,6 @@ let empty : t = {
sets_of_closures = Set_of_closures_id.Map.empty;
closures = Closure_id.Map.empty;
values = Compilation_unit.Map.empty;
globals = Ident.Map.empty;
symbol_id = Symbol.Map.empty;
offset_fun = Closure_id.Map.empty;
offset_fv = Var_within_closure.Map.empty;
@ -153,13 +153,12 @@ let empty : t = {
invariant_params = Set_of_closures_id.Map.empty;
}
let create ~sets_of_closures ~closures ~values ~globals ~symbol_id
let create ~sets_of_closures ~closures ~values ~symbol_id
~offset_fun ~offset_fv ~constant_sets_of_closures
~invariant_params =
{ sets_of_closures;
closures;
values;
globals;
symbol_id;
offset_fun;
offset_fv;
@ -186,7 +185,6 @@ let merge (t1 : t) (t2 : t) : t =
in
let int_eq (i : int) j = i = j in
{ values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values;
globals = Ident.Map.disjoint_union t1.globals t2.globals;
sets_of_closures =
Set_of_closures_id.Map.disjoint_union t1.sets_of_closures
t2.sets_of_closures;
@ -314,9 +312,6 @@ let print_approx ppf (t : t) =
print_approx approx)
bound_vars
in
let print_approxs id approx =
fprintf ppf "%a -> %a;@ " Ident.print id print_approx approx
in
let rec print_recorded_symbols () =
if not (Queue.is_empty symbols_to_print) then begin
let sym = Queue.pop symbols_to_print in
@ -331,7 +326,6 @@ let print_approx ppf (t : t) =
end
in
fprintf ppf "@[<hov 2>Globals:@ ";
Ident.Map.iter print_approxs t.globals;
fprintf ppf "@]@ @[<hov 2>Symbols:@ ";
print_recorded_symbols ();
fprintf ppf "@]"

6
asmcomp/export_info.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
(** Exported information (that is to say, information written into a .cmx
file) about a compilation unit. *)
@ -80,9 +82,6 @@ type t = private {
(** Code of exported functions indexed by closure IDs. *)
values : descr Export_id.Map.t Compilation_unit.Map.t;
(** Structure of exported values. *)
globals : approx Ident.Map.t;
(** Global variables provided by the unit: usually only the top-level
module identifier, but packs may contain more than one. *)
symbol_id : Export_id.t Symbol.Map.t;
(** Associates symbols and values. *)
offset_fun : int Closure_id.Map.t;
@ -104,7 +103,6 @@ val create
: sets_of_closures:Flambda.function_declarations Set_of_closures_id.Map.t
-> closures:Flambda.function_declarations Closure_id.Map.t
-> values:descr Export_id.Map.t Compilation_unit.Map.t
-> globals:approx Ident.Map.t
-> symbol_id:Export_id.t Symbol.Map.t
-> offset_fun:int Closure_id.Map.t
-> offset_fv:int Var_within_closure.Map.t

10
asmcomp/export_info_for_pack.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
let rename_id_state = Export_id.Tbl.create 100
(* Rename export identifiers' compilation units to denote that they now
@ -115,7 +117,6 @@ let import_eidmap_for_pack units pack f map =
let import_for_pack ~pack_units ~pack (exp : Export_info.t) =
let import_sym = import_symbol_for_pack pack_units pack in
let import_descr = import_descr_for_pack pack_units pack in
let import_approx = import_approx_for_pack pack_units pack in
let import_eid = import_eid_for_pack pack_units pack in
let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in
let sets_of_closures =
@ -123,15 +124,8 @@ let import_for_pack ~pack_units ~pack (exp : Export_info.t) =
(import_function_declarations_for_pack pack_units pack)
exp.sets_of_closures
in
(* The only reachable global identifier of a pack is the pack itself. *)
let globals =
Ident.Map.filter (fun unit _ ->
Ident.same (Compilation_unit.get_persistent_ident pack) unit)
exp.globals
in
Export_info.create ~sets_of_closures
~closures:(Flambda_utils.make_closure_map' sets_of_closures)
~globals:(Ident.Map.map import_approx globals)
~offset_fun:exp.offset_fun
~offset_fv:exp.offset_fv
~values:(import_eidmap import_descr exp.values)

2
asmcomp/export_info_for_pack.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
(** Transformations on export information that are only used for the
building of packs. *)

3
asmcomp/flambda_to_clambda.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
type for_one_or_more_units = {
fun_offset_table : int Closure_id.Map.t;
fv_offset_table : int Var_within_closure.Map.t;
@ -660,6 +662,7 @@ let convert (program, exported) : result =
List.map (fun (symbol, tag, fields) ->
{ Clambda.
symbol = Linkage_name.to_string (Symbol.label symbol);
exported = true;
tag = Tag.to_int tag;
size = List.length fields;
})

2
asmcomp/flambda_to_clambda.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
type result = {
expr : Clambda.ulambda;
preallocated_blocks : Clambda.preallocated_block list;

2
asmcomp/import_approx.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
module A = Simple_value_approx
let import_set_of_closures =

2
asmcomp/import_approx.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
(** Create simple value approximations from the export information in
.cmx files. *)

33
asmcomp/un_anf.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-30-40-41-42"]
(* We say that an [Ident.t] is "linear" iff:
(a) it is used exactly once;
(b) it is never assigned to (using [Uassign]).
@ -731,20 +733,17 @@ and un_anf_array ident_info env clams : Clambda.ulambda array =
Array.map (un_anf ident_info env) clams
let apply clam ~what =
if not Config.flambda then clam
else begin
let ident_info = make_ident_info clam in
let let_bound_vars_that_can_be_moved =
let_bound_vars_that_can_be_moved ident_info clam
in
let clam =
substitute_let_moveable let_bound_vars_that_can_be_moved
Ident.Map.empty clam
in
let ident_info = make_ident_info clam in
let clam = un_anf ident_info Ident.Map.empty clam in
if !Clflags.dump_clambda then begin
Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam
end;
clam
end
let ident_info = make_ident_info clam in
let let_bound_vars_that_can_be_moved =
let_bound_vars_that_can_be_moved ident_info clam
in
let clam =
substitute_let_moveable let_bound_vars_that_can_be_moved
Ident.Map.empty clam
in
let ident_info = make_ident_info clam in
let clam = un_anf ident_info Ident.Map.empty clam in
if !Clflags.dump_clambda then begin
Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam
end;
clam

2
asmrun/Makefile
View File

@ -29,7 +29,7 @@ COBJS=startup_aux.o startup.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_OR_WIN32).o backtrace_prim.o \
backtrace.o \
natdynlink.o debugger.o meta.o dynlink.o
natdynlink.o debugger.o meta.o dynlink.o clambda_checks.o
ASMOBJS=$(ARCH).o

2
asmrun/Makefile.nt
View File

@ -25,7 +25,7 @@ COBJS=startup_aux.$(O) startup.$(O) \
md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \
weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \
backtrace_prim.$(O) backtrace.$(O) \
natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O)
natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) clambda_checks.$(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 \

1
asmrun/signals_asm.c
View File

@ -67,7 +67,6 @@ extern char caml_system__code_begin, caml_system__code_end;
void caml_garbage_collection(void)
{
CAMLassert (caml_young_ptr >= caml_young_alloc_start);
caml_young_limit = caml_young_trigger;
if (caml_requested_major_slice || caml_requested_minor_gc ||
caml_young_ptr - caml_young_trigger < Max_young_whsize){

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

19
bytecomp/bytegen.ml
View File

@ -153,10 +153,11 @@ let rec size_of_lambda = function
| Llet(str, id, arg, body) -> size_of_lambda body
| Lletrec(bindings, body) -> size_of_lambda body
| Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args)
| Lprim (Pmakearray (Paddrarray|Pintarray), args) ->
| Lprim (Pmakearray ((Paddrarray|Pintarray), _), args) ->
RHS_block (List.length args)
| Lprim (Pmakearray Pfloatarray, args) -> RHS_floatblock (List.length args)
| Lprim (Pmakearray Pgenarray, args) -> assert false
| Lprim (Pmakearray (Pfloatarray, _), args) ->
RHS_floatblock (List.length args)
| Lprim (Pmakearray (Pgenarray, _), args) -> assert false
| Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) ->
RHS_block size
| Lprim (Pduprecord (Record_extension, size), args) ->
@ -632,7 +633,7 @@ let rec comp_expr env exp sz cont =
(Kpush::
Kconst (Const_base (Const_int n))::
Kaddint::cont)
| Lprim(Pmakearray kind, args) ->
| Lprim(Pmakearray (kind, _), args) ->
begin match kind with
Pintarray | Paddrarray ->
comp_args env args sz (Kmakeblock(List.length args, 0) :: cont)
@ -645,6 +646,16 @@ let rec comp_expr env exp sz cont =
(Kmakeblock(List.length args, 0) ::
Kccall("caml_make_array", 1) :: cont)
end
| Lprim (Pduparray (kind, mutability), [Lprim (Pmakearray (kind', _), args)]) ->
assert (kind = kind');
comp_expr env (Lprim (Pmakearray (kind, mutability), args)) sz cont
| Lprim (Pduparray _, [arg]) ->
let prim_obj_dup =
Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
in
comp_expr env (Lprim (Pccall prim_obj_dup, [arg])) sz cont
| Lprim (Pduparray _, _) ->
Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg"
(* Integer first for enabling futher optimization (cf. emitcode.ml) *)
| Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) ->
let p = Pintcomp (commute_comparison c)

3
bytecomp/bytepackager.ml
View File

@ -265,8 +265,7 @@ let package_files ppf initial_env files targetfile =
try
let coercion =
Typemod.package_units initial_env files targetcmi targetname in
let ret = package_object_files ppf files targetfile targetname coercion in
ret
package_object_files ppf files targetfile targetname coercion
with x ->
remove_file targetfile; raise x

9
bytecomp/lambda.ml
View File

@ -77,7 +77,8 @@ type primitive =
(* String operations *)
| Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets
(* Array operations *)
| Pmakearray of array_kind
| Pmakearray of array_kind * mutable_flag
| Pduparray of array_kind * mutable_flag
| Parraylength of array_kind
| Parrayrefu of array_kind
| Parraysetu of array_kind
@ -242,6 +243,10 @@ and lambda_event_kind =
| Lev_after of Types.type_expr
| Lev_function
type program =
{ code : lambda;
main_module_block_size : int; }
let const_unit = Const_pointer 0
let lambda_unit = Lconst const_unit
@ -274,7 +279,7 @@ let make_key e =
try Ident.find_same id env
with Not_found -> e
end
| Lconst (Const_base (Const_string _)|Const_float_array _) ->
| Lconst (Const_base (Const_string _)) ->
(* Mutable constants are not shared *)
raise Not_simple
| Lconst _ -> e

12
bytecomp/lambda.mli
View File

@ -80,7 +80,11 @@ type primitive =
(* String operations *)
| Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets
(* Array operations *)
| Pmakearray of array_kind
| Pmakearray of array_kind * mutable_flag
| Pduparray of array_kind * mutable_flag
(** For [Pduparray], the argument must be an immutable array.
The arguments of [Pduparray] give the kind and mutability of the
array being *produced* by the duplication. *)
| Parraylength of array_kind
| Parrayrefu of array_kind
| Parraysetu of array_kind
@ -255,6 +259,12 @@ and lambda_event_kind =
| Lev_after of Types.type_expr
| Lev_function
type program =
{ code : lambda;
main_module_block_size : int; }
(* Lambda code for the Closure middle-end. The main module block size
is required for preallocating the block *)
(* Sharing key *)
val make_key: lambda -> lambda option

8
bytecomp/printlambda.ml
View File

@ -177,7 +177,10 @@ let primitive ppf = function
| Pstringrefs -> fprintf ppf "string.get"
| Pstringsets -> fprintf ppf "string.set"
| Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k)
| Pmakearray k -> fprintf ppf "makearray[%s]" (array_kind k)
| Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k)
| Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k)
| Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k)
| Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k)
| Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k)
| Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k)
| Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k)
@ -313,6 +316,7 @@ let name_of_primitive = function
| Pstringsets -> "Pstringsets"
| Parraylength _ -> "Parraylength"
| Pmakearray _ -> "Pmakearray"
| Pduparray _ -> "Pduparray"
| Parrayrefu _ -> "Parrayrefu"
| Parraysetu _ -> "Parraysetu"
| Parrayrefs _ -> "Parrayrefs"
@ -528,3 +532,5 @@ and sequence ppf = function
let structured_constant = struct_const
let lambda = lam
let program ppf { code } = lambda ppf code

1
bytecomp/printlambda.mli
View File

@ -16,5 +16,6 @@ open Format
val structured_constant: formatter -> structured_constant -> unit
val lambda: formatter -> lambda -> unit
val program: formatter -> program -> unit
val primitive: formatter -> primitive -> unit
val name_of_primitive : primitive -> string

6
bytecomp/switch.ml
View File

@ -375,8 +375,7 @@ let ok_inter = ref false
let rec opt_count top cases =
let key = make_key cases in
try
let r = Hashtbl.find t key in
r
Hashtbl.find t key
with
| Not_found ->
let r =
@ -813,8 +812,7 @@ let do_zyva (low,high) arg cases actions =
*)
let n_clusters,k = comp_clusters s in
let clusters = make_clusters s n_clusters k in
let r = c_test {arg=arg ; off=0} clusters in
r
c_test {arg=arg ; off=0} clusters
let abstract_shared actions =
let handlers = ref (fun x -> x) in

59
bytecomp/translcore.ml
View File

@ -30,6 +30,8 @@ type error =
exception Error of Location.t * error
let use_dup_for_constant_arrays_bigger_than = 4
(* Forward declaration -- to be filled in by Translmod.transl_module *)
let transl_module =
ref((fun cc rootpath modl -> assert false) :
@ -444,8 +446,8 @@ let check_recursive_lambda idlist lam =
let idlist' = add_letrec bindings idlist in
List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
check_top idlist' body
| Lprim (Pmakearray (Pgenarray), args) -> false
| Lprim (Pmakearray Pfloatarray, args) ->
| Lprim (Pmakearray (Pgenarray, _), args) -> false
| Lprim (Pmakearray (Pfloatarray, _), args) ->
List.for_all (check idlist) args
| Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2
| Levent (lam, _) -> check_top idlist lam
@ -464,8 +466,8 @@ let check_recursive_lambda idlist lam =
check idlist' body
| Lprim(Pmakeblock(tag, mut), args) ->
List.for_all (check idlist) args
| Lprim (Pmakearray Pfloatarray, _) -> false
| Lprim(Pmakearray(_), args) ->
| Lprim (Pmakearray (Pfloatarray, _), _) -> false
| Lprim (Pmakearray _, args) ->
List.for_all (check idlist) args
| Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2
| Levent (lam, _) -> check idlist lam
@ -849,20 +851,43 @@ and transl_exp0 e =
let kind = array_kind e in
let ll = transl_list expr_list in
begin try
(* For native code the decision as to which compilation strategy to
use is made later. This enables the Flambda passes to lift certain
kinds of array definitions to symbols. *)
(* 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])
if List.length ll <= use_dup_for_constant_arrays_bigger_than
then begin
raise Not_constant
end;
begin match List.map extract_constant ll with
| exception Not_constant when kind = Pfloatarray ->
(* We cannot currently lift [Pintarray] arrays safely in Flambda
because [caml_modify] might be called upon them (e.g. from
code operating on polymorphic arrays, or functions such as
[caml_array_blit].
To avoid having different Lambda code for bytecode/Closure vs.
Flambda, we always generate [Pduparray] here, and deal with it in
[Bytegen] (or in the case of Closure, in [Cmmgen], which already
has to handle [Pduparray Pmakearray Pfloatarray] in the case where
the array turned out to be inconstant).
When not [Pfloatarray], the exception propagates to the handler
below. *)
let imm_array = Lprim (Pmakearray (kind, Immutable), ll) in
Lprim (Pduparray (kind, Mutable), [imm_array])
| cl ->
let imm_array =
match kind with
| Paddrarray | Pintarray ->
Lconst(Const_block(0, cl))
| Pfloatarray ->
Lconst(Const_float_array(List.map extract_float cl))
| Pgenarray ->
raise Not_constant (* can this really happen? *)
in
Lprim (Pduparray (kind, Mutable), [imm_array])
end
with Not_constant ->
Lprim(Pmakearray kind, ll)
Lprim(Pmakearray (kind, Mutable), ll)
end
| Texp_ifthenelse(cond, ifso, Some ifnot) ->
Lifthenelse(transl_exp cond,
@ -1203,7 +1228,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
match repres with
Record_regular -> Lprim(Pmakeblock(0, mut), ll)
| Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll)
| Record_float -> Lprim(Pmakearray Pfloatarray, ll)
| Record_float -> Lprim(Pmakearray (Pfloatarray, mut), ll)
| Record_extension ->
let path =
match all_labels.(0).lbl_res.desc with

22
bytecomp/translmod.ml
View File

@ -566,13 +566,13 @@ let transl_implementation_flambda module_name (str, cc) =
Hashtbl.clear used_primitives;
let module_id = Ident.create_persistent module_name in
let body, size =
transl_label_init
Translobj.transl_label_init
(fun () -> transl_struct [] cc (global_path module_id) str)
in
module_id, (wrap_globals body, size)
(module_id, size), wrap_globals body
let transl_implementation module_name (str, cc) =
let module_id, (module_initializer, _size) =
let (module_id, _size), module_initializer =
transl_implementation_flambda module_name (str, cc)
in
Lprim (Psetglobal module_id, [module_initializer])
@ -907,7 +907,8 @@ let transl_store_implementation module_name (str, restr) =
transl_store_subst := Ident.empty;
let (i, r) = transl_store_gen module_name (str, restr) false in
transl_store_subst := s;
(i, wrap_globals r)
{ Lambda.main_module_block_size = i;
code = wrap_globals r; }
(* Compile a toplevel phrase *)
@ -1024,6 +1025,19 @@ let get_component = function
None -> Lconst const_unit
| Some id -> Lprim(Pgetglobal id, [])
let transl_package_flambda component_names target_name coercion =
let size =
match coercion with
| Tcoerce_none -> List.length component_names
| Tcoerce_structure (l, _) -> List.length l
| Tcoerce_functor _
| Tcoerce_primitive _
| Tcoerce_alias _ -> assert false
in
size,
apply_coercion Strict coercion
(Lprim(Pmakeblock(0, Immutable), List.map get_component component_names))
let transl_package component_names target_name coercion =
let components =
Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) in

9
bytecomp/translmod.mli
View File

@ -19,13 +19,20 @@ open Lambda
val transl_implementation: string -> structure * module_coercion -> lambda
val transl_store_phrases: string -> structure -> int * lambda
val transl_store_implementation:
string -> structure * module_coercion -> int * lambda
string -> structure * module_coercion -> Lambda.program
val transl_implementation_flambda:
string -> structure * module_coercion -> (Ident.t * int) * lambda
val transl_toplevel_definition: structure -> lambda
val transl_package:
Ident.t option list -> Ident.t -> module_coercion -> lambda
val transl_store_package:
Ident.t option list -> Ident.t -> module_coercion -> int * lambda
val transl_package_flambda:
Ident.t option list -> Ident.t -> module_coercion -> int * lambda
val toplevel_name: Ident.t -> string
val nat_toplevel_name: Ident.t -> Ident.t * int

24
bytecomp/translobj.ml
View File

@ -107,7 +107,26 @@ let transl_label_init_general f =
reset_labels ();
expr, size
let transl_label_init_flambda f =
assert(Config.flambda);
let method_cache_id = Ident.create "method_cache" in
method_cache := Lvar method_cache_id;
(* Calling f (usualy Translmod.transl_struct) requires the
method_cache variable to be initialised to be able to generate
method accesses. *)
let expr, size = f () in
let expr =
if !method_count = 0 then expr
else
Llet (Strict, method_cache_id,
Lprim (Pccall prim_makearray, [int !method_count; int 0]),
expr)
in
transl_label_init_general (fun () -> expr, size)
let transl_store_label_init glob size f arg =
assert(not Config.flambda);
assert(!Clflags.native_code);
method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]);
let expr = f arg in
let (size, expr) =
@ -123,7 +142,10 @@ let transl_store_label_init glob size f arg =
size, lam
let transl_label_init f =
transl_label_init_general f
if !Clflags.native_code then
transl_label_init_flambda f
else
transl_label_init_general f
(* Share classes *)

11
byterun/Makefile.nt
View File

@ -15,13 +15,20 @@ include Makefile.common
CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR)
ifdef BOOTSTRAPPING_FLEXLINK
MAKE_OCAMLRUN=$(MKEXE_BOOT)
CFLAGS:=-DBOOTSTRAPPING_FLEXLINK $(CFLAGS)
else
MAKE_OCAMLRUN=$(MKEXE) -o $(1) $(2)
endif
DBGO=d.$(O)
OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O)
DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO)
ocamlrun$(EXE): libcamlrun.$(A) prims.$(O)
$(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) \
$(EXTRALIBS) libcamlrun.$(A)
$(call MAKE_OCAMLRUN,ocamlrun$(EXE),prims.$(O) libcamlrun.$(A) \
$(call SYSLIB,ws2_32) $(EXTRALIBS))
ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O)
$(MKEXE) -o ocamlrund$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \

3
byterun/caml/config.h
View File

@ -19,6 +19,9 @@
/* <private> */
#include "../../config/m.h"
#include "../../config/s.h"
#ifdef BOOTSTRAPPING_FLEXLINK
#undef SUPPORT_DYNAMIC_LINKING
#endif
/* </private> */
#ifndef CAML_NAME_SPACE

24
byterun/caml/major_gc.h
View File

@ -38,13 +38,23 @@ extern uintnat caml_dependent_size, caml_dependent_allocated;
extern uintnat caml_fl_wsz_at_phase_change;
#define Phase_mark 0
#define Phase_sweep 1
#define Phase_idle 2
#define Subphase_roots 10
#define Subphase_main 11
#define Subphase_weak1 12
#define Subphase_weak2 13
#define Subphase_final 14
#define Phase_clean 1
#define Phase_sweep 2
#define Phase_idle 3
/* Subphase of mark */
#define Subphase_mark_roots 10
/* Subphase_mark_roots: At the end of this subphase all the global
roots are marked. */
#define Subphase_mark_main 11
/* Subphase_mark_main: At the end of this subphase all the value alive at
the start of this subphase and created during it are marked. */
#define Subphase_mark_final 12
/* Subphase_mark_final: At the start of this subphase register which
value with an ocaml finalizer are not marked, the associated
finalizer will be run later. So we mark now these value as alive,
since they must be available for their finalizer.
*/
CAMLextern char *caml_heap_start;
extern uintnat total_heap_size;

45
byterun/caml/minor_gc.h
View File

@ -25,17 +25,26 @@ CAMLextern value *caml_young_trigger;
extern asize_t caml_minor_heap_wsz;
extern int caml_in_minor_collection;
struct caml_ref_table {
value **base;
value **end;
value **threshold;
value **ptr;
value **limit;
asize_t size;
asize_t reserve;
#define CAML_TABLE_STRUCT(t) { \
t *base; \
t *end; \
t *threshold; \
t *ptr; \
t *limit; \
asize_t size; \
asize_t reserve; \
}
struct caml_ref_table CAML_TABLE_STRUCT(value *);
CAMLextern struct caml_ref_table caml_ref_table, caml_finalize_table;
struct caml_ephe_ref_elt {
value ephe; /* an ephemeron in major heap */
mlsize_t offset; /* the offset that points in the minor heap */
};
CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table,
caml_finalize_table;
struct caml_ephe_ref_table CAML_TABLE_STRUCT(struct caml_ephe_ref_elt);
CAMLextern struct caml_ephe_ref_table caml_ephe_ref_table;
extern void caml_set_minor_heap_size (asize_t); /* size in bytes */
extern void caml_empty_minor_heap (void);
@ -43,6 +52,9 @@ CAMLextern void caml_gc_dispatch (void);
CAMLextern void garbage_collection (void); /* def in asmrun/signals_asm.c */
extern void caml_realloc_ref_table (struct caml_ref_table *);
extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t);
extern void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *);
extern void caml_alloc_ephe_table (struct caml_ephe_ref_table *,
asize_t, asize_t);
extern void caml_oldify_one (value, value *);
extern void caml_oldify_mopup (void);
@ -62,4 +74,17 @@ static inline void add_to_ref_table (struct caml_ref_table *tbl, value *p)
*tbl->ptr++ = p;
}
static inline void add_to_ephe_ref_table (struct caml_ephe_ref_table *tbl,
value ar, mlsize_t offset)
{
struct caml_ephe_ref_elt *ephe_ref;
if (tbl->ptr >= tbl->limit){
CAMLassert (tbl->ptr == tbl->limit);
caml_realloc_ephe_ref_table (tbl);
}
ephe_ref = tbl->ptr++;
ephe_ref->ephe = ar;
ephe_ref->offset = offset;
}
#endif /* CAML_MINOR_GC_H */

66
byterun/caml/weak.h
View File

@ -18,7 +18,69 @@
#include "mlvalues.h"
extern value caml_weak_list_head;
extern value caml_weak_none;
extern value caml_ephe_list_head;
extern value caml_ephe_none;
/** The first field 0: weak list;
second field 1: data;
others 2..: keys;
A weak pointer is an ephemeron with the data at caml_ephe_none
*/
#define CAML_EPHE_LINK_OFFSET 0
#define CAML_EPHE_DATA_OFFSET 1
#define CAML_EPHE_FIRST_KEY 2
/* In the header, in order to let major_gc.c
and weak.c see the body of the function */
static inline void caml_ephe_clean (value v){
value child;
int release_data = 0;
mlsize_t size, i;
header_t hd;
Assert(caml_gc_phase == Phase_clean);
hd = Hd_val (v);
size = Wosize_hd (hd);
for (i = 2; i < size; i++){
child = Field (v, i);
ephemeron_again:
if (child != caml_ephe_none
&& Is_block (child) && Is_in_heap_or_young (child)){
if (Tag_val (child) == Forward_tag){
value f = Forward_val (child);
if (Is_block (f)) {
if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){
/* Do not short-circuit the pointer. */
}else{
Field (v, i) = child = f;
if (Is_block (f) && Is_young (f))
add_to_ephe_ref_table(&caml_ephe_ref_table, v, i);
goto ephemeron_again;
}
}
}
if (Is_white_val (child) && !Is_young (child)){
release_data = 1;
Field (v, i) = caml_ephe_none;
}
}
}
child = Field (v, 1);
if(child != caml_ephe_none){
if (release_data){
Field (v, 1) = caml_ephe_none;
} else {
/* The mark phase must have marked it */
Assert( !(Is_block (child) && Is_in_heap (child)
&& Is_white_val (child)) );
}
}
}
#endif /* CAML_WEAK_H */

6
byterun/compact.c
View File

@ -221,7 +221,7 @@ static void do_compaction (void)
}
/* Invert weak pointers. */
{
value *pp = &caml_weak_list_head;
value *pp = &caml_ephe_list_head;
value p;
word q;
size_t sz, i;
@ -233,7 +233,7 @@ static void do_compaction (void)
while (Ecolor (q) == 0) q = * (word *) q;
sz = Wosize_ehd (q);
for (i = 1; i < sz; i++){
if (Field (p,i) != caml_weak_none){
if (Field (p,i) != caml_ephe_none){
invert_pointer_at ((word *) &(Field (p,i)));
}
}
@ -402,7 +402,7 @@ void caml_compact_heap (void)
CAMLassert (caml_young_ptr == caml_young_alloc_end);
CAMLassert (caml_ref_table.ptr == caml_ref_table.base);
CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.base);
CAMLassert (caml_ephe_ref_table.ptr == caml_ephe_ref_table.base);
do_compaction ();
CAML_INSTR_TIME (tmr, "compact/main");

419
byterun/major_gc.c
View File

@ -44,7 +44,8 @@ uintnat caml_percent_free;
uintnat caml_major_heap_increment;
CAMLexport char *caml_heap_start;
char *caml_gc_sweep_hp;
int caml_gc_phase; /* always Phase_mark, Phase_sweep, or Phase_idle */
int caml_gc_phase; /* always Phase_mark, Pase_clean,
Phase_sweep, or Phase_idle */
static value *gray_vals;
static value *gray_vals_cur, *gray_vals_end;
static asize_t gray_vals_size;
@ -59,8 +60,47 @@ extern char *caml_fl_merge; /* Defined in freelist.c. */
static char *markhp, *chunk, *limit;
int caml_gc_subphase; /* Subphase_{main,weak1,weak2,final} */
static value *weak_prev;
int caml_gc_subphase; /* Subphase_{mark_roots,mark_main,mark_final} */
/**
Ephemerons:
During mark phase the list caml_ephe_list_head of ephemerons
is iterated by different pointers that follow the invariants:
caml_ephe_list_head ->* ephes_checked_if_pure ->* ephes_to_check ->* null
| | |
(1) (2) (3)
At the start of mark phase, (1) and (2) are empty.
In mark phase:
- the ephemerons in (1) have a data alive or none
(nb: new ephemerons are added in this part by weak.c)
- the ephemerons in (2) have at least a white key or are white
if ephe_list_pure is true, otherwise they are in an unknown state and
must be checked again.
- the ephemerons in (3) are in an unknown state and must be checked
At the end of mark phase, (3) is empty and ephe_list_pure is true.
The ephemeron in (1) and (2) will be cleaned (white keys and datas
replaced by none or the ephemeron is removed from the list if it is white)
in clean phase.
In clean phase:
caml_ephe_list_head ->* ephes_to_check ->* null
| |
(1) (3)
In clean phase, (2) is not used, ephes_to_check is initialized at
caml_ephe_list_head:
- the ephemerons in (1) are clean.
- the ephemerons in (3) should be cleaned or removed if white.
*/
static int ephe_list_pure;
/** The ephemerons is pure if since the start of its iteration
no value have been darken. */
static value *ephes_checked_if_pure;
static value *ephes_to_check;
int caml_major_window = 1;
double caml_major_ring[Max_major_window] = { 0. };
@ -126,6 +166,7 @@ void caml_darken (value v, value *p /* not used */)
#endif
CAMLassert (!Is_blue_hd (h));
if (Is_white_hd (h)){
ephe_list_pure = 0;
if (t < No_scan_tag){
Hd_val (v) = Grayhd_hd (h);
*gray_vals_cur++ = v;
@ -144,8 +185,11 @@ static void start_cycle (void)
caml_gc_message (0x01, "Starting new major GC cycle\n", 0);
caml_darken_all_roots_start ();
caml_gc_phase = Phase_mark;
caml_gc_subphase = Subphase_roots;
caml_gc_subphase = Subphase_mark_roots;
markhp = NULL;
ephe_list_pure = 1;
ephes_checked_if_pure = &caml_ephe_list_head;
ephes_to_check = &caml_ephe_list_head;
#ifdef DEBUG
++ major_gc_counter;
caml_heap_check ();
@ -159,25 +203,179 @@ static void start_cycle (void)
static value current_value = 0;
static mlsize_t current_index = 0;
/* For instrumentation */
#ifdef CAML_INSTR
#define INSTR(x) x
#else
#define INSTR(x) /**/
#endif
static void init_sweep_phase(void)
{
/* Phase_clean is done. */
/* Initialise the sweep phase. */
caml_gc_sweep_hp = caml_heap_start;
caml_fl_init_merge ();
caml_gc_phase = Phase_sweep;
chunk = caml_heap_start;
caml_gc_sweep_hp = chunk;
limit = chunk + Chunk_size (chunk);
caml_fl_wsz_at_phase_change = caml_fl_cur_wsz;
if (caml_major_gc_hook) (*caml_major_gc_hook)();
}
/* auxillary function of mark_slice */
static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i,
int in_ephemeron, int *slice_pointers)
{
value child;
header_t chd;
child = Field (v, i);
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
if (Is_block (child)
&& ! Is_young (child)
&& Wosize_val (child) > 0 /* Atoms never need to be marked. */
/* Closure blocks contain code pointers at offsets that cannot
be reliably determined, so we always use the page table when
marking such values. */
&& (!(Tag_val (v) == Closure_tag || Tag_val (v) == Infix_tag) ||
Is_in_heap (child))) {
#else
if (Is_block (child) && Is_in_heap (child)) {
#endif
INSTR (++ *slice_pointers;)
chd = Hd_val (child);
if (Tag_hd (chd) == Forward_tag){
value f = Forward_val (child);
if ((in_ephemeron && Is_long(f)) ||
(Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){
/* Do not short-circuit the pointer. */
}else{
/* The variable child is not changed because it must be mark alive */
Field (v, i) = f;
if (Is_block (f) && Is_young (f) && !Is_young (child)){
if(in_ephemeron){
add_to_ephe_ref_table (&caml_ephe_ref_table, v, i);
}else{
add_to_ref_table (&caml_ref_table, &Field (v, i));
}
}
}
}
else if (Tag_hd(chd) == Infix_tag) {
child -= Infix_offset_val(child);
chd = Hd_val(child);
}
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
/* See [caml_darken] for a description of this assertion. */
CAMLassert (Is_in_heap (child) || Is_black_hd (chd));
#endif
if (Is_white_hd (chd)){
ephe_list_pure = 0;
Hd_val (child) = Grayhd_hd (chd);
*gray_vals_ptr++ = child;
if (gray_vals_ptr >= gray_vals_end) {
gray_vals_cur = gray_vals_ptr;
realloc_gray_vals ();
gray_vals_ptr = gray_vals_cur;
}
}
}
return gray_vals_ptr;
}
static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work,
int *slice_pointers)
{
value v, data, key;
header_t hd;
mlsize_t size, i;
v = *ephes_to_check;
hd = Hd_val(v);
Assert(Tag_val (v) == Abstract_tag);
data = Field(v,CAML_EPHE_DATA_OFFSET);
if ( data != caml_ephe_none &&
Is_block (data) && Is_in_heap (data) && Is_white_val (data)){
int alive_data = 1;
/* The liveness of the ephemeron is one of the condition */
if (Is_white_hd (hd)) alive_data = 0;
/* The liveness of the keys not caml_ephe_none is the other condition */
size = Wosize_hd (hd);
for (i = CAML_EPHE_FIRST_KEY; alive_data && i < size; i++){
key = Field (v, i);
ephemeron_again:
if (key != caml_ephe_none &&
Is_block (key) && Is_in_heap (key)){
if (Tag_val (key) == Forward_tag){
value f = Forward_val (key);
if (Is_long (f) ||
(Is_block (f) &&
(!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){
/* Do not short-circuit the pointer. */
}else{
Field (v, i) = key = f;
goto ephemeron_again;
}
}
if (Is_white_val (key)){
alive_data = 0;
}
}
}
*work -= Whsize_wosize(i);
if (alive_data){
gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,
CAML_EPHE_DATA_OFFSET,
/*in_ephemeron=*/1,
slice_pointers);
} else { /* not triggered move to the next one */
ephes_to_check = &Field(v,CAML_EPHE_LINK_OFFSET);
return gray_vals_ptr;
}
} else { /* a simily weak pointer or an already alive data */
*work -= 1;
}
/* all keys black or data none or black
move the ephemerons from (3) to the end of (1) */
if ( ephes_checked_if_pure == ephes_to_check ) {
/* corner case and optim */
ephes_checked_if_pure = &Field(v,CAML_EPHE_LINK_OFFSET);
ephes_to_check = ephes_checked_if_pure;
} else {
/* - remove v from the list (3) */
*ephes_to_check = Field(v,CAML_EPHE_LINK_OFFSET);
/* - insert it at the end of (1) */
Field(v,CAML_EPHE_LINK_OFFSET) = *ephes_checked_if_pure;
*ephes_checked_if_pure = v;
ephes_checked_if_pure = &Field(v,CAML_EPHE_LINK_OFFSET);
}
return gray_vals_ptr;
}
static void mark_slice (intnat work)
{
value *gray_vals_ptr; /* Local copy of [gray_vals_cur] */
value v, child;
header_t hd, chd;
value v;
header_t hd;
mlsize_t size, i, start, end; /* [start] is a local copy of [current_index] */
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
int marking_closure = 0;
#endif
#ifdef CAML_INSTR
int slice_fields = 0;
int slice_pointers = 0;
#endif
int slice_pointers = 0; /** gcc removes it when not in CAML_INSTR */
caml_gc_message (0x40, "Marking %ld words\n", work);
caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase);
@ -192,10 +390,6 @@ static void mark_slice (intnat work)
}
if (v != 0){
hd = Hd_val(v);
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
marking_closure =
(Tag_hd (hd) == Closure_tag || Tag_hd (hd) == Infix_tag);
#endif
Assert (Is_gray_hd (hd));
size = Wosize_hd (hd);
end = start + work;
@ -207,49 +401,9 @@ static void mark_slice (intnat work)
INSTR (if (size > end)
CAML_INSTR_INT ("major/mark/slice/remain", size - end);)
for (i = start; i < end; i++){
child = Field (v, i);
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
if (Is_block (child)
&& ! Is_young (child)
&& Wosize_val (child) > 0 /* Atoms never need to be marked. */
/* Closure blocks contain code pointers at offsets that cannot
be reliably determined, so we always use the page table when
marking such values. */
&& (!marking_closure || Is_in_heap (child))) {
#else
if (Is_block (child) && Is_in_heap (child)) {
#endif
INSTR (++ slice_pointers;)
chd = Hd_val (child);
if (Tag_hd (chd) == Forward_tag){
value f = Forward_val (child);
if (Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
Field (v, i) = f;
if (Is_block (f) && Is_young (f) && !Is_young (child))
add_to_ref_table (&caml_ref_table, &Field (v, i));
}
}else if (Tag_hd(chd) == Infix_tag) {
child -= Infix_offset_val(child);
chd = Hd_val(child);
}
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
/* See [caml_darken] for a description of this assertion. */
CAMLassert (Is_in_heap (child) || Is_black_hd (chd));
#endif
if (Is_white_hd (chd)){
Hd_val (child) = Grayhd_hd (chd);
*gray_vals_ptr++ = child;
if (gray_vals_ptr >= gray_vals_end) {
gray_vals_cur = gray_vals_ptr;
realloc_gray_vals ();
gray_vals_ptr = gray_vals_cur;
}
}
}
gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,i,
/*in_ephemeron=*/ 0,
&slice_pointers);
}
if (end < size){
work = 0;
@ -292,62 +446,25 @@ static void mark_slice (intnat work)
chunk = caml_heap_start;
markhp = chunk;
limit = chunk + Chunk_size (chunk);
} else if (caml_gc_subphase == Subphase_mark_roots) {
gray_vals_cur = gray_vals_ptr;
work = caml_darken_all_roots_slice (work);
gray_vals_ptr = gray_vals_cur;
if (work > 0){
caml_gc_subphase = Subphase_mark_main;
}
} else if (*ephes_to_check != (value) NULL) {
/* Continue to scan the list of ephe */
gray_vals_ptr = mark_ephe_aux(gray_vals_ptr,&work,&slice_pointers);
} else if (!ephe_list_pure){
/* We must scan again the list because some value have been darken */
ephe_list_pure = 1;
ephes_to_check = ephes_checked_if_pure;
}else{
switch (caml_gc_subphase){
case Subphase_roots: {
gray_vals_cur = gray_vals_ptr;
work = caml_darken_all_roots_slice (work);
gray_vals_ptr = gray_vals_cur;
if (work > 0){
caml_gc_subphase = Subphase_main;
}
}
break;
case Subphase_main: {
/* The main marking phase is over. Start removing weak pointers to
dead values. */
caml_gc_subphase = Subphase_weak1;
weak_prev = &caml_weak_list_head;
}
break;
case Subphase_weak1: {
value cur, curfield;
mlsize_t sz, i;
header_t hd;
cur = *weak_prev;
if (cur != (value) NULL){
hd = Hd_val (cur);
sz = Wosize_hd (hd);
for (i = 1; i < sz; i++){
curfield = Field (cur, i);
weak_again:
if (curfield != caml_weak_none
&& Is_block (curfield) && Is_in_heap_or_young (curfield)){
if (Tag_val (curfield) == Forward_tag){
value f = Forward_val (curfield);
if (Is_block (f)) {
if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){
/* Do not short-circuit the pointer. */
}else{
Field (cur, i) = curfield = f;
if (Is_block (f) && Is_young (f))
add_to_ref_table (&caml_weak_ref_table, &Field (cur, i));
goto weak_again;
}
}
}
if (Is_white_val (curfield) && !Is_young (curfield)){
Field (cur, i) = caml_weak_none;
}
}
}
weak_prev = &Field (cur, 0);
work -= Whsize_hd (hd);
}else{
/* Subphase_weak1 is done.
Handle finalised values and start removing dead weak arrays. */
case Subphase_mark_main: {
/* Subphase_mark_main is done.
Mark finalised values. */
gray_vals_cur = gray_vals_ptr;
caml_final_update ();
gray_vals_ptr = gray_vals_cur;
@ -355,44 +472,25 @@ static void mark_slice (intnat work)
v = *--gray_vals_ptr;
CAMLassert (start == 0);
}
caml_gc_subphase = Subphase_weak2;
weak_prev = &caml_weak_list_head;
}
/* Complete the marking */
ephes_to_check = ephes_checked_if_pure;
caml_gc_subphase = Subphase_mark_final;
}
break;
case Subphase_weak2: {
value cur;
header_t hd;
cur = *weak_prev;
if (cur != (value) NULL){
hd = Hd_val (cur);
if (Color_hd (hd) == Caml_white){
/* The whole array is dead, remove it from the list. */
*weak_prev = Field (cur, 0);
}else{
weak_prev = &Field (cur, 0);
}
work -= 1;
}else{
/* Subphase_weak2 is done. Go to Subphase_final. */
caml_gc_subphase = Subphase_final;
case Subphase_mark_final: {
if (caml_ephe_list_head != (value) NULL){
/* Initialise the clean phase. */
caml_gc_phase = Phase_clean;
ephes_to_check = &caml_ephe_list_head;
work = 0;
} else {
/* Initialise the sweep phase,
shortcut the unneeded clean phase. */
init_sweep_phase();
work = 0;
}
}
break;
case Subphase_final: {
/* Initialise the sweep phase. */
caml_gc_sweep_hp = caml_heap_start;
caml_fl_init_merge ();
caml_gc_phase = Phase_sweep;
chunk = caml_heap_start;
caml_gc_sweep_hp = chunk;
limit = chunk + Chunk_size (chunk);
work = 0;
caml_fl_wsz_at_phase_change = caml_fl_cur_wsz;
if (caml_major_gc_hook) (*caml_major_gc_hook)();
}
break;
default: Assert (0);
}
}
@ -404,6 +502,33 @@ static void mark_slice (intnat work)
INSTR (CAML_INSTR_INT ("major/mark/slice/pointers#", slice_pointers);)
}
/* Clean ephemerons */
static void clean_slice (intnat work)
{
value v;
caml_gc_message (0x40, "Cleaning %ld words\n", work);
while (work > 0){
v = *ephes_to_check;
if (v != (value) NULL){
if (Is_white_val (v)){
/* The whole array is dead, remove it from the list. */
*ephes_to_check = Field (v, CAML_EPHE_LINK_OFFSET);
work -= 1;
}else{
caml_ephe_clean(v);
ephes_to_check = &Field (v, CAML_EPHE_LINK_OFFSET);
work -= Whsize_val (v);
}
}else{ /* End of list reached */
/* Phase_clean is done. */
/* Initialise the sweep phase. */
init_sweep_phase();
work = 0;
}
}
}
static void sweep_slice (intnat work)
{
char *hp;
@ -625,7 +750,7 @@ void caml_major_collection_slice (intnat howmuch)
goto finished;
}
if (caml_gc_phase == Phase_mark){
if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean){
computed_work = (intnat) (p * (caml_stat_heap_wsz * 250
/ (100 + caml_percent_free)
+ caml_incremental_roots_count));
@ -638,6 +763,9 @@ void caml_major_collection_slice (intnat howmuch)
mark_slice (computed_work);
CAML_INSTR_TIME (tmr, mark_slice_name[caml_gc_subphase]);
caml_gc_message (0x02, "!", 0);
}else if (caml_gc_phase == Phase_clean){
clean_slice (computed_work);
caml_gc_message (0x02, "%%", 0);
}else{
Assert (caml_gc_phase == Phase_sweep);
CAML_INSTR_INT ("major/work/sweep#", computed_work);
@ -682,6 +810,7 @@ void caml_finish_major_cycle (void)
{
if (caml_gc_phase == Phase_idle) start_cycle ();
while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX);
while (caml_gc_phase == Phase_clean) clean_slice (LONG_MAX);
Assert (caml_gc_phase == Phase_sweep);
while (caml_gc_phase == Phase_sweep) sweep_slice (LONG_MAX);
Assert (caml_gc_phase == Phase_idle);

4
byterun/memory.c
View File

@ -445,7 +445,7 @@ void caml_shrink_heap (char *chunk)
color_t caml_allocation_color (void *hp)
{
if (caml_gc_phase == Phase_mark
if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean
|| (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
return Caml_black;
}else{
@ -486,7 +486,7 @@ static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag,
Assert (Is_in_heap (Val_hp (hp)));
/* Inline expansion of caml_allocation_color. */
if (caml_gc_phase == Phase_mark
if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean
|| (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
Hd_hp (hp) = Make_header (wosize, tag, Caml_black);
}else{

144
byterun/minor_gc.c
View File

@ -49,6 +49,8 @@
native code, or [caml_young_trigger].
*/
struct generic_table CAML_TABLE_STRUCT(char);
asize_t caml_minor_heap_wsz;
static void *caml_young_base = NULL;
CAMLexport value *caml_young_start = NULL, *caml_young_end = NULL;
@ -60,21 +62,24 @@ CAMLexport value *caml_young_trigger = NULL;
CAMLexport struct caml_ref_table
caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0},
caml_weak_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0},
caml_finalize_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
/* table of custom blocks containing finalizers in the minor heap */
CAMLexport struct caml_ephe_ref_table
caml_ephe_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
int caml_in_minor_collection = 0;
/* [sz] and [rsv] are numbers of entries */
void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv)
static void alloc_generic_table (struct generic_table *tbl, asize_t sz,
asize_t rsv, asize_t element_size)
{
value **new_table;
void *new_table;
tbl->size = sz;
tbl->reserve = rsv;
new_table = (value **) caml_stat_alloc ((tbl->size + tbl->reserve)
* sizeof (value *));
new_table = (void *) caml_stat_alloc ((tbl->size + tbl->reserve)
* element_size);
if (tbl->base != NULL) caml_stat_free (tbl->base);
tbl->base = new_table;
tbl->ptr = tbl->base;
@ -83,7 +88,19 @@ void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv)
tbl->end = tbl->base + tbl->size + tbl->reserve;
}
static void reset_table (struct caml_ref_table *tbl)
void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv)
{
alloc_generic_table ((struct generic_table *) tbl, sz, rsv, sizeof (value *));
}
void caml_alloc_ephe_table (struct caml_ephe_ref_table *tbl, asize_t sz,
asize_t rsv)
{
alloc_generic_table ((struct generic_table *) tbl, sz, rsv,
sizeof (struct caml_ephe_ref_elt));
}
static void reset_table (struct generic_table *tbl)
{
tbl->size = 0;
tbl->reserve = 0;
@ -91,7 +108,7 @@ static void reset_table (struct caml_ref_table *tbl)
tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL;
}
static void clear_table (struct caml_ref_table *tbl)
static void clear_table (struct generic_table *tbl)
{
tbl->ptr = tbl->base;
tbl->limit = tbl->threshold;
@ -165,8 +182,8 @@ void caml_set_minor_heap_size (asize_t bsz)
caml_young_ptr = caml_young_alloc_end;
caml_minor_heap_wsz = Wsize_bsize (bsz);
reset_table (&caml_ref_table);
reset_table (&caml_weak_ref_table);
reset_table ((struct generic_table *) &caml_ref_table);
reset_table ((struct generic_table *) &caml_ephe_ref_table);
}
static value oldify_todo_list = 0;
@ -257,6 +274,21 @@ void caml_oldify_one (value v, value *p)
}
}
/* Test if the ephemeron is alive, everything outside minor heap is alive */
static inline int ephe_check_alive_data(struct caml_ephe_ref_elt *re){
mlsize_t i;
value child;
for (i = 2; i < Wosize_val(re->ephe); i++){
child = Field (re->ephe, i);
if(child != caml_ephe_none
&& Is_block (child) && Is_young (child)
&& Hd_val (child) != 0){ /* Value not copied to major heap */
return 0;
}
}
return 1;
}
/* Finish the work that was put off by [caml_oldify_one].
Note that [caml_oldify_one] itself is called by oldify_mopup, so we
have to be careful to remove the first entry from the list before
@ -265,6 +297,8 @@ void caml_oldify_mopup (void)
{
value v, new_v, f;
mlsize_t i;
struct caml_ephe_ref_elt *re;
int redo = 0;
while (oldify_todo_list != 0){
v = oldify_todo_list; /* Get the head. */
@ -285,6 +319,28 @@ void caml_oldify_mopup (void)
}
}
}
/* Oldify the data in the minor heap of alive ephemeron
During minor collection keys outside the minor heap are considered alive */
for (re = caml_ephe_ref_table.base;
re < caml_ephe_ref_table.ptr; re++){
/* look only at ephemeron with data in the minor heap */
if (re->offset == 1){
value *data = &Field(re->ephe,1);
if (*data != caml_ephe_none && Is_block (*data) && Is_young (*data)){
if (Hd_val (*data) == 0){ /* Value copied to major heap */
*data = Field (*data, 0);
} else {
if (ephe_check_alive_data(re)){
caml_oldify_one(*data,data);
redo = 1; /* oldify_todo_list can still be 0 */
}
}
}
}
}
if (redo) caml_oldify_mopup ();
}
/* Make sure the minor heap is empty by performing a minor collection
@ -294,6 +350,7 @@ void caml_empty_minor_heap (void)
{
value **r;
uintnat prev_alloc_words;
struct caml_ephe_ref_elt *re;
if (caml_young_ptr != caml_young_alloc_end){
if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) ();
@ -309,15 +366,21 @@ void caml_empty_minor_heap (void)
CAML_INSTR_TIME (tmr, "minor/ref_table");
caml_oldify_mopup ();
CAML_INSTR_TIME (tmr, "minor/copy");
for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){
if (Is_block (**r) && Is_young (**r)){
if (Hd_val (**r) == 0){
**r = Field (**r, 0);
}else{
**r = caml_weak_none;
/* Update the ephemerons */
for (re = caml_ephe_ref_table.base;
re < caml_ephe_ref_table.ptr; re++){
value *key = &Field(re->ephe,re->offset);
if (*key != caml_ephe_none && Is_block (*key) && Is_young (*key)){
if (Hd_val (*key) == 0){ /* Value copied to major heap */
*key = Field (*key, 0);
}else{ /* Value not copied so it's dead */
Assert(!ephe_check_alive_data(re));
*key = caml_ephe_none;
Field(re->ephe,1) = caml_ephe_none;
}
}
}
/* Run custom block finalisation of dead minor value */
for (r = caml_finalize_table.base; r < caml_finalize_table.ptr; r++){
int hd = Hd_val ((value)*r);
if (hd != 0){ /* If not oldified the finalizer must be called */
@ -326,14 +389,13 @@ void caml_empty_minor_heap (void)
}
}
CAML_INSTR_TIME (tmr, "minor/update_weak");
CAMLassert (caml_young_ptr >= caml_young_alloc_start);
caml_stat_minor_words += caml_young_alloc_end - caml_young_ptr;
caml_gc_clock += (double) (caml_young_alloc_end - caml_young_ptr)
/ caml_minor_heap_wsz;
caml_young_ptr = caml_young_alloc_end;
clear_table (&caml_ref_table);
clear_table (&caml_weak_ref_table);
clear_table (&caml_finalize_table);
clear_table ((struct generic_table *) &caml_ref_table);
clear_table ((struct generic_table *) &caml_ephe_ref_table);
clear_table ((struct generic_table *) &caml_finalize_table);
caml_gc_message (0x02, ">", 0);
caml_in_minor_collection = 0;
caml_final_empty_young ();
@ -428,16 +490,20 @@ CAMLexport value caml_check_urgent_gc (value extra_root)
CAMLreturn (extra_root);
}
void caml_realloc_ref_table (struct caml_ref_table *tbl)
{ Assert (tbl->ptr == tbl->limit);
static void realloc_generic_table
(struct generic_table *tbl, asize_t element_size,
char * msg_intr_int, char *msg_threshold, char *msg_growing, char *msg_error)
{
Assert (tbl->ptr == tbl->limit);
Assert (tbl->limit <= tbl->end);
Assert (tbl->limit >= tbl->threshold);
if (tbl->base == NULL){
caml_alloc_table (tbl, caml_minor_heap_wsz / 8, 256);
alloc_generic_table (tbl, caml_minor_heap_wsz / 8, 256,
element_size);
}else if (tbl->limit == tbl->threshold){
CAML_INSTR_INT ("request_minor/realloc_ref_table@", 1);
caml_gc_message (0x08, "ref_table threshold crossed\n", 0);
CAML_INSTR_INT (msg_intr_int, 1);
caml_gc_message (0x08, msg_threshold, 0);
tbl->limit = tbl->end;
caml_request_minor_gc ();
}else{
@ -446,13 +512,11 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl)
CAMLassert (caml_requested_minor_gc);
tbl->size *= 2;
sz = (tbl->size + tbl->reserve) * sizeof (value *);
caml_gc_message (0x08, "Growing ref_table to %"
ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
(intnat) sz/1024);
tbl->base = (value **) realloc ((char *) tbl->base, sz);
sz = (tbl->size + tbl->reserve) * element_size;
caml_gc_message (0x08, msg_growing, (intnat) sz/1024);
tbl->base = (void *) realloc ((char *) tbl->base, sz);
if (tbl->base == NULL){
caml_fatal_error ("Fatal error: ref_table overflow\n");
caml_fatal_error (msg_error);
}
tbl->end = tbl->base + tbl->size + tbl->reserve;
tbl->threshold = tbl->base + tbl->size;
@ -460,3 +524,23 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl)
tbl->limit = tbl->end;
}
}
void caml_realloc_ref_table (struct caml_ref_table *tbl)
{
realloc_generic_table
((struct generic_table *) tbl, sizeof (value *),
"request_minor/realloc_ref_table@",
"ref_table threshold crossed\n",
"Growing ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
"Fatal error: ref_table overflow\n");
}
void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *tbl)
{
realloc_generic_table
((struct generic_table *) tbl, sizeof (struct caml_ephe_ref_elt),
"request_minor/realloc_ephe_ref_table@",
"ephe_ref_table threshold crossed\n",
"Growing ephe_ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
"Fatal error: ephe_ref_table overflow\n");
}

2
byterun/str.c
View File

@ -294,7 +294,7 @@ CAMLexport value caml_alloc_sprintf(const char * format, ...)
int n;
value res;
#ifndef _WIN32
#if !defined(_WIN32) || defined(_UCRT)
/* C99-compliant implementation */
va_start(args, format);
/* "vsnprintf(dest, sz, format, args)" writes at most "sz" characters

320
byterun/weak.c
View File

@ -11,7 +11,7 @@
/* */
/***********************************************************************/
/* Operations on weak arrays */
/* Operations on weak arrays and ephemerons (named ephe here)*/
#include <string.h>
@ -20,30 +20,123 @@
#include "caml/major_gc.h"
#include "caml/memory.h"
#include "caml/mlvalues.h"
#include "caml/weak.h"
value caml_weak_list_head = 0;
value caml_ephe_list_head = 0;
static value ephe_dummy = 0;
value caml_ephe_none = (value) &ephe_dummy;
#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS)
/** The minor heap is considered alive.
Outside minor and major heap, x must be black.
*/
static inline int Is_Dead_during_clean(value x){
Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean);
return Is_block (x) && !Is_young (x) && Is_white_val(x);
}
/** The minor heap doesn't have to be marked, outside they should
already be black
*/
static inline int Must_be_Marked_during_mark(value x){
Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark);
return Is_block (x) && !Is_young (x);
}
#else
static inline int Is_Dead_during_clean(value x){
Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean);
return Is_block (x) && Is_in_heap (x) && Is_white_val(x);
}
static inline int Must_be_Marked_during_mark(value x){
Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark);
return Is_block (x) && Is_in_heap (x);
}
#endif
static value weak_dummy = 0;
value caml_weak_none = (value) &weak_dummy;
/* [len] is a value that represents a number of words (fields) */
CAMLprim value caml_weak_create (value len)
CAMLprim value caml_ephe_create (value len)
{
mlsize_t size, i;
value res;
size = Long_val (len) + 1;
size = Long_val (len) + 1 /* weak_list */ + 1 /* the value */;
if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create");
res = caml_alloc_shr (size, Abstract_tag);
for (i = 1; i < size; i++) Field (res, i) = caml_weak_none;
Field (res, 0) = caml_weak_list_head;
caml_weak_list_head = res;
for (i = 1; i < size; i++) Field (res, i) = caml_ephe_none;
Field (res, CAML_EPHE_LINK_OFFSET) = caml_ephe_list_head;
caml_ephe_list_head = res;
return res;
}
CAMLprim value caml_weak_create (value len)
{
return caml_ephe_create(len);
}
/**
Specificity of the cleaning phase (Phase_clean):
The dead keys must be removed from the ephemerons and data removed
when one the keys is dead. Here we call it cleaning the ephemerons.
A specific phase of the GC is dedicated to this, Phase_clean. This
phase is just after the mark phase, so the white values are dead
values. It iterates the function caml_ephe_clean through all the
ephemerons.
However the GC is incremental and ocaml code can run on the middle
of this cleaning phase. In order to respect the semantic of the
ephemerons concerning dead values, the getter and setter must work
as if the cleaning of all the ephemerons have been done at once.
- key getter: Even if a dead key have not yet been replaced by
caml_ephe_none, getting it should return none.
- key setter: If we replace a dead key we need to set the data to
caml_ephe_none and clean the ephemeron.
This two cases are dealt by a call to do_check_key_clean that
trigger the cleaning of the ephemerons when the accessed key is
dead. This test is fast.
In the case of value getter and value setter, there is no fast
test because the removing of the data depend of the deadliness of the keys.
We must always try to clean the ephemerons.
*/
#define None_val (Val_int(0))
#define Some_tag 0
/* If we are in Phase_clean we need to check if the key
that is going to disappear is dead and so should trigger a cleaning
*/
static void do_check_key_clean(value ar, mlsize_t offset){
Assert ( offset >= 2);
if (caml_gc_phase == Phase_clean){
value elt = Field (ar, offset);
if (elt != caml_ephe_none && Is_Dead_during_clean(elt)){
Field(ar,offset) = caml_ephe_none;
Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
};
};
}
/* If we are in Phase_clean we need to do as if the key is empty when
it will be cleaned during this phase */
static inline int is_ephe_key_none(value ar, mlsize_t offset){
value elt = Field (ar, offset);
if (elt == caml_ephe_none){
return 1;
}else if (caml_gc_phase == Phase_clean && Is_Dead_during_clean(elt)){
Field(ar,offset) = caml_ephe_none;
Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
return 1;
} else {
return 0;
}
}
static void do_set (value ar, mlsize_t offset, value v)
{
if (Is_block (v) && Is_young (v)){
@ -51,46 +144,119 @@ static void do_set (value ar, mlsize_t offset, value v)
value old = Field (ar, offset);
Field (ar, offset) = v;
if (!(Is_block (old) && Is_young (old))){
add_to_ref_table (&caml_weak_ref_table, &Field (ar, offset));
add_to_ephe_ref_table (&caml_ephe_ref_table, ar, offset);
}
}else{
Field (ar, offset) = v;
}
}
CAMLprim value caml_weak_set (value ar, value n, value el)
CAMLprim value caml_ephe_set_key (value ar, value n, value el)
{
mlsize_t offset = Long_val (n) + 1;
mlsize_t offset = Long_val (n) + 2;
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
if (offset < 2 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.set");
}
do_check_key_clean(ar,offset);
do_set (ar, offset, el);
return Val_unit;
}
CAMLprim value caml_ephe_unset_key (value ar, value n)
{
mlsize_t offset = Long_val (n) + 2;
Assert (Is_in_heap (ar));
if (offset < 2 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.set");
}
do_check_key_clean(ar,offset);
Field (ar, offset) = caml_ephe_none;
return Val_unit;
}
value caml_ephe_set_key_option (value ar, value n, value el)
{
mlsize_t offset = Long_val (n) + 2;
Assert (Is_in_heap (ar));
if (offset < 2 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.set");
}
do_check_key_clean(ar,offset);
if (el != None_val && Is_block (el)){
Assert (Wosize_val (el) == 1);
do_set (ar, offset, Field (el, 0));
}else{
Field (ar, offset) = caml_weak_none;
Field (ar, offset) = caml_ephe_none;
}
return Val_unit;
}
CAMLprim value caml_weak_set (value ar, value n, value el){
return caml_ephe_set_key_option(ar,n,el);
}
CAMLprim value caml_ephe_set_data (value ar, value el)
{
Assert (Is_in_heap (ar));
if (caml_gc_phase == Phase_clean){
/* During this phase since we don't know which ephemeron have been
cleaned we always need to check it. */
caml_ephe_clean(ar);
};
do_set (ar, 1, el);
return Val_unit;
}
CAMLprim value caml_ephe_unset_data (value ar)
{
Assert (Is_in_heap (ar));
Field (ar, CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
return Val_unit;
}
#define Setup_for_gc
#define Restore_after_gc
CAMLprim value caml_weak_get (value ar, value n)
CAMLprim value caml_ephe_get_key (value ar, value n)
{
CAMLparam2 (ar, n);
mlsize_t offset = Long_val (n) + 1;
mlsize_t offset = Long_val (n) + 2;
CAMLlocal2 (res, elt);
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get");
if (offset < 2 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get_key");
}
if (Field (ar, offset) == caml_weak_none){
if (is_ephe_key_none(ar, offset)){
res = None_val;
}else{
elt = Field (ar, offset);
if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){
if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){
caml_darken (elt, NULL);
}
res = caml_alloc_small (1, Some_tag);
Field (res, 0) = elt;
}
CAMLreturn (res);
}
CAMLprim value caml_weak_get (value ar, value n){
return caml_ephe_get_key(ar, n);
}
CAMLprim value caml_ephe_get_data (value ar)
{
CAMLparam1 (ar);
mlsize_t offset = 1;
CAMLlocal2 (res, elt);
Assert (Is_in_heap (ar));
elt = Field (ar, offset);
if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
if (elt == caml_ephe_none){
res = None_val;
}else{
if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){
caml_darken (elt, NULL);
}
res = caml_alloc_small (1, Some_tag);
@ -102,29 +268,29 @@ CAMLprim value caml_weak_get (value ar, value n)
#undef Setup_for_gc
#undef Restore_after_gc
CAMLprim value caml_weak_get_copy (value ar, value n)
CAMLprim value caml_ephe_get_key_copy (value ar, value n)
{
CAMLparam2 (ar, n);
mlsize_t offset = Long_val (n) + 1;
mlsize_t offset = Long_val (n) + 2;
CAMLlocal2 (res, elt);
value v; /* Caution: this is NOT a local root. */
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get");
caml_invalid_argument ("Weak.get_copy");
}
if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val);
v = Field (ar, offset);
if (v == caml_weak_none) CAMLreturn (None_val);
if (Is_block (v) && Is_in_heap_or_young(v)) {
elt = caml_alloc (Wosize_val (v), Tag_val (v));
/* The GC may erase or move v during this call to caml_alloc. */
v = Field (ar, offset);
if (v == caml_weak_none) CAMLreturn (None_val);
if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val);
if (Tag_val (v) < No_scan_tag){
mlsize_t i;
for (i = 0; i < Wosize_val (v); i++){
value f = Field (v, i);
if (caml_gc_phase == Phase_mark && Is_block (f) && Is_in_heap (f)){
if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){
caml_darken (f, NULL);
}
Modify (&Field (elt, i), f);
@ -141,21 +307,74 @@ CAMLprim value caml_weak_get_copy (value ar, value n)
CAMLreturn (res);
}
CAMLprim value caml_weak_check (value ar, value n)
{
mlsize_t offset = Long_val (n) + 1;
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get");
}
return Val_bool (Field (ar, offset) != caml_weak_none);
CAMLprim value caml_weak_get_copy (value ar, value n){
return caml_ephe_get_key_copy(ar,n);
}
CAMLprim value caml_weak_blit (value ars, value ofs,
CAMLprim value caml_ephe_get_data_copy (value ar)
{
CAMLparam1 (ar);
mlsize_t offset = 1;
CAMLlocal2 (res, elt);
value v; /* Caution: this is NOT a local root. */
Assert (Is_in_heap (ar));
v = Field (ar, offset);
if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
if (v == caml_ephe_none) CAMLreturn (None_val);
if (Is_block (v) && Is_in_heap_or_young(v)) {
elt = caml_alloc (Wosize_val (v), Tag_val (v));
/* The GC may erase or move v during this call to caml_alloc. */
v = Field (ar, offset);
if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
if (v == caml_ephe_none) CAMLreturn (None_val);
if (Tag_val (v) < No_scan_tag){
mlsize_t i;
for (i = 0; i < Wosize_val (v); i++){
value f = Field (v, i);
if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){
caml_darken (f, NULL);
}
Modify (&Field (elt, i), f);
}
}else{
memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
}
}else{
elt = v;
}
res = caml_alloc_small (1, Some_tag);
Field (res, 0) = elt;
CAMLreturn (res);
}
CAMLprim value caml_ephe_check_key (value ar, value n)
{
mlsize_t offset = Long_val (n) + 2;
Assert (Is_in_heap (ar));
if (offset < 2 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.check");
}
return Val_bool (!is_ephe_key_none(ar, offset));
}
CAMLprim value caml_weak_check (value ar, value n)
{
return caml_ephe_check_key(ar,n);
}
CAMLprim value caml_ephe_check_data (value ar)
{
if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
return Val_bool (Field (ar, CAML_EPHE_DATA_OFFSET) != caml_ephe_none);
}
CAMLprim value caml_ephe_blit_key (value ars, value ofs,
value ard, value ofd, value len)
{
mlsize_t offset_s = Long_val (ofs) + 1;
mlsize_t offset_d = Long_val (ofd) + 1;
mlsize_t offset_s = Long_val (ofs) + 2;
mlsize_t offset_d = Long_val (ofd) + 2;
mlsize_t length = Long_val (len);
long i;
Assert (Is_in_heap (ars));
@ -166,14 +385,9 @@ CAMLprim value caml_weak_blit (value ars, value ofs,
if (offset_d < 1 || offset_d + length > Wosize_val (ard)){
caml_invalid_argument ("Weak.blit");
}
if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){
for (i = 0; i < length; i++){
value v = Field (ars, offset_s + i);
if (v != caml_weak_none && Is_block (v) && Is_in_heap (v)
&& Is_white_val (v)){
Field (ars, offset_s + i) = caml_weak_none;
}
}
if (caml_gc_phase == Phase_clean){
caml_ephe_clean(ars);
caml_ephe_clean(ard);
}
if (offset_d < offset_s){
for (i = 0; i < length; i++){
@ -186,3 +400,19 @@ CAMLprim value caml_weak_blit (value ars, value ofs,
}
return Val_unit;
}
CAMLprim value caml_ephe_blit_data (value ars, value ard)
{
if(caml_gc_phase == Phase_clean) {
caml_ephe_clean(ars);
caml_ephe_clean(ard);
};
do_set (ard, CAML_EPHE_DATA_OFFSET, Field (ars, CAML_EPHE_DATA_OFFSET));
return Val_unit;
}
CAMLprim value caml_weak_blit (value ars, value ofs,
value ard, value ofd, value len)
{
return caml_ephe_blit_key (ars, ofs, ard, ofd, len);
}

22
config/Makefile.mingw
View File

@ -86,6 +86,7 @@ RUNTIMED=noruntimed
ASM_CFI_SUPPORTED=false
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
########## Configuration for the bytecode compiler
@ -109,13 +110,28 @@ NATIVECCLIBS=-lws2_32
CPP=$(BYTECC) -E
### Flexlink
FLEXLINK=flexlink -chain mingw -stack 16777216 -link -static-libgcc
FLEXDIR:=$(shell $(FLEXLINK) -where)
FLEXLINK_CMD=flexlink
FLEXDLL_CHAIN=mingw
# FLEXLINK_FLAGS must be safe to insert in an OCaml string
# (see ocamlmklibconfig.ml in tools/Makefile.nt)
FLEXLINK_FLAGS=-chain $(FLEXDLL_CHAIN) -stack 16777216 -link -static-libgcc
FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null)
ifeq ($(FLEXDIR),)
IFLEXDIR=-I"../flexdll"
else
IFLEXDIR=-I"$(FLEXDIR)"
endif
# MKDLL, MKEXE and MKMAINDLL must ultimately be equivalent to
# $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll]
# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
MKMAINDLL=$(FLEXLINK) -maindll
### Native command to build ocamlrun.exe without flexlink
MKEXE_BOOT=$(BYTECC) -o $(1) $(2)
### How to build a static library
MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1)
#ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;;
@ -173,5 +189,5 @@ OTOPDIR=$(WINTOPDIR)
CTOPDIR=$(TOPDIR)
CYGPATH=cygpath -m
DIFF=diff -q --strip-trailing-cr
CANKILL=false
SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
MAX_TESTSUITE_DIR_RETRIES=1

22
config/Makefile.mingw64
View File

@ -86,6 +86,7 @@ RUNTIMED=noruntimed
ASM_CFI_SUPPORTED=false
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
########## Configuration for the bytecode compiler
@ -109,13 +110,28 @@ NATIVECCLIBS=-lws2_32
CPP=$(BYTECC) -E
### Flexlink
FLEXLINK=flexlink -chain mingw64 -stack 33554432
FLEXDIR:=$(shell $(FLEXLINK) -where)
FLEXLINK_CMD=flexlink
FLEXDLL_CHAIN=mingw64
# FLEXLINK_FLAGS must be safe to insert in an OCaml string
# (see ocamlmklibconfig.ml in tools/Makefile.nt)
FLEXLINK_FLAGS=-chain $(FLEXDLL_CHAIN) -stack 33554432
FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null)
ifeq ($(FLEXDIR),)
IFLEXDIR=-I"../flexdll"
else
IFLEXDIR=-I"$(FLEXDIR)"
endif
# MKDLL, MKEXE and MKMAINDLL must ultimately be equivalent to
# $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll]
# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
MKMAINDLL=$(FLEXLINK) -maindll
### Native command to build ocamlrun.exe without flexlink
MKEXE_BOOT=$(BYTECC) -o $(1) $(2)
### How to build a static library
MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1)
#ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;;
@ -173,5 +189,5 @@ OTOPDIR=$(WINTOPDIR)
CTOPDIR=$(TOPDIR)
CYGPATH=cygpath -m
DIFF=diff -q --strip-trailing-cr
CANKILL=false
SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
MAX_TESTSUITE_DIR_RETRIES=1

23
config/Makefile.msvc
View File

@ -77,6 +77,7 @@ RUNTIMED=noruntimed
ASM_CFI_SUPPORTED=false
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
########## Configuration for the bytecode compiler
@ -100,13 +101,29 @@ NATIVECCLIBS=advapi32.lib ws2_32.lib
CPP=cl -nologo -EP
### Flexlink
FLEXLINK=flexlink -merge-manifest -stack 16777216
FLEXDIR:=$(shell $(FLEXLINK) -where)
FLEXLINK_CMD=flexlink
FLEXDLL_CHAIN=msvc
# FLEXLINK_FLAGS must be safe to insert in an OCaml string
# (see ocamlmklibconfig.ml in tools/Makefile.nt)
FLEXLINK_FLAGS=-merge-manifest -stack 16777216
FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null)
ifeq ($(FLEXDIR),)
IFLEXDIR=-I"../flexdll"
else
IFLEXDIR=-I"$(FLEXDIR)"
endif
# MKDLL, MKEXE and MKMAINDLL must ultimately be equivalent to
# $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll]
# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
MKMAINDLL=$(FLEXLINK) -maindll
### Native command to build ocamlrun.exe without flexlink
MERGEMANIFESTEXE=test ! -f $(1).manifest || mt -nologo -outputresource:$(1) -manifest $(1).manifest && rm -f $(1).manifest
MKEXE_BOOT=$(BYTECC) /Fe$(1) $(2) /link /subsystem:console && ($(MERGEMANIFESTEXE))
### How to build a static library
MKLIB=link -lib -nologo -out:$(1) $(2)
#ml let mklib out files opts = Printf.sprintf "link -lib -nologo -out:%s %s %s" out opts files;;
@ -174,7 +191,7 @@ OTOPDIR=$(WINTOPDIR)
CTOPDIR=$(WINTOPDIR)
CYGPATH=cygpath -m
DIFF=diff -q --strip-trailing-cr
CANKILL=false
FIND=/usr/bin/find
SORT=/usr/bin/sort
SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
MAX_TESTSUITE_DIR_RETRIES=1

23
config/Makefile.msvc64
View File

@ -76,6 +76,7 @@ RUNTIMED=noruntimed
ASM_CFI_SUPPORTED=false
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
########## Configuration for the bytecode compiler
@ -104,13 +105,29 @@ NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS)
CPP=cl -nologo -EP
### Flexlink
FLEXLINK=flexlink -x64 -merge-manifest -stack 33554432
FLEXDIR:=$(shell $(FLEXLINK) -where)
FLEXLINK_CMD=flexlink
FLEXDLL_CHAIN=msvc64
# FLEXLINK_FLAGS must be safe to insert in an OCaml string
# (see ocamlmklibconfig.ml in tools/Makefile.nt)
FLEXLINK_FLAGS=-x64 -merge-manifest -stack 33554432
FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null)
ifeq ($(FLEXDIR),)
IFLEXDIR=-I"../flexdll"
else
IFLEXDIR=-I"$(FLEXDIR)"
endif
# MKDLL, MKEXE and MKMAINDLL must ultimately be equivalent to
# $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll]
# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
MKMAINDLL=$(FLEXLINK) -maindll
### Native command to build ocamlrun.exe without flexlink
MERGEMANIFESTEXE=test ! -f $(1).manifest || mt -nologo -outputresource:$(1) -manifest $(1).manifest && rm -f $(1).manifest
MKEXE_BOOT=$(BYTECC) /Fe$(1) $(2) /link /subsystem:console && ($(MERGEMANIFESTEXE))
### How to build a static library
MKLIB=link -lib -nologo -machine:AMD64 /out:$(1) $(2)
#ml let mklib out files opts = Printf.sprintf "link -lib -nologo -machine:AMD64 -out:%s %s %s" out opts files;;
@ -178,7 +195,7 @@ OTOPDIR=$(WINTOPDIR)
CTOPDIR=$(WINTOPDIR)
CYGPATH=cygpath -m
DIFF=diff -q --strip-trailing-cr
CANKILL=false
FIND=/usr/bin/find
SORT=/usr/bin/sort
SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
MAX_TESTSUITE_DIR_RETRIES=1

31
configure vendored
View File

@ -51,6 +51,8 @@ no_naked_pointers=false
native_compiler=true
TOOLPREF=""
with_cfi=true
flambda=false
max_testsuite_dir_retries=0
# Try to turn internationalization off, can cause config.guess to malfunction!
unset LANG
@ -162,6 +164,8 @@ while : ; do
with_cfi=false;;
-no-native-compiler)
native_compiler=false;;
-flambda)
flambda=true;;
*) if echo "$1" | grep -q -e '^--\?[a-zA-Z0-9-]\+='; then
err "configure expects arguments of the form '-prefix /foo/bar'," \
"not '-prefix=/foo/bar' (note the '=')."
@ -1058,6 +1062,23 @@ if test "$with_curses" = "yes"; then
done
fi
# For instrumented runtime
# (clock_gettime needs -lrt for glibc before 2.17)
if $with_instrumented_runtime; then
with_instrumented_runtime=false #enabled it only if found
for libs in "" "-lrt"; do
if sh ./hasgot $libs clock_gettime; then
inf "clock_gettime functions found (with libraries '$libs')"
instrumented_runtime_libs="${libs}"
with_instrumented_runtime=true;
break
fi
done
if ! $with_instrumented_runtime; then
err "clock_gettime functions not found. Instrumented runtime can't be built."
fi
fi
# Configuration for the libraries
case "$system" in
@ -1716,7 +1737,8 @@ cclibs="$cclibs $mathlib"
echo "BYTECC=$bytecc" >> Makefile
echo "BYTECCCOMPOPTS=$bytecccompopts" >> Makefile
echo "BYTECCLINKOPTS=$bytecclinkopts" >> Makefile
echo "BYTECCLIBS=$cclibs $dllib $curseslibs $pthread_link" >> Makefile
echo "BYTECCLIBS=$cclibs $dllib $curseslibs $pthread_link \
$instrumented_runtime_libs" >> Makefile
echo "BYTECCRPATH=$byteccrpath" >> Makefile
echo "EXE=$exe" >> Makefile
echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile
@ -1788,6 +1810,8 @@ echo "HOST=$host" >> Makefile
if [ "$ostype" = Cygwin ]; then
echo "DIFF=diff -q --strip-trailing-cr" >>Makefile
fi
echo "FLAMBDA=$flambda" >> Makefile
echo "MAX_TESTSUITE_DIR_RETRIES=$max_testsuite_dir_retries" >> Makefile
rm -f tst hasgot.c
@ -1856,6 +1880,11 @@ else
else
inf " profiling with gprof ..... not supported"
fi
if test "$flambda" = "true"; then
inf " using flambda middle-end . yes"
else
inf " using flambda middle-end . no"
fi
fi
if test "$with_debugger" = "ocamldebugger"; then

6
debugger/Makefile.shared
View File

@ -30,14 +30,14 @@ INCLUDES=\
OTHEROBJS=\
$(UNIXDIR)/unix.cma \
../utils/config.cmo ../utils/tbl.cmo \
../utils/clflags.cmo ../utils/misc.cmo \
../utils/config.cmo ../utils/tbl.cmo ../utils/misc.cmo \
../utils/identifiable.cmo ../utils/numbers.cmo \
../utils/arg_helper.cmo ../utils/clflags.cmo \
../utils/consistbl.cmo ../utils/warnings.cmo \
../utils/terminfo.cmo \
../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \
../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \
../parsing/attr_helper.cmo \
../parsing/ast_iterator.cmo ../parsing/attr_helper.cmo \
../parsing/builtin_attributes.cmo \
../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \

473
driver/compenv.ml
View File

@ -93,9 +93,10 @@ let module_of_filename ppf inputfile outputprefix =
name
;;
type filename = string
type readenv_position =
Before_args | Before_compile | Before_link
Before_args | Before_compile of filename | Before_link
(* Syntax of OCAMLPARAM: (name=VALUE,)* _ (,name=VALUE)*
where VALUE should not contain ',' *)
@ -138,10 +139,242 @@ let setter ppf f name options s =
(Warnings.Bad_env_variable ("OCAMLPARAM",
Printf.sprintf "bad value for %s" name))
let int_setter ppf name option s =
try
option := int_of_string s
with _ ->
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable
("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name))
let float_setter ppf name option s =
try
option := float_of_string s
with _ ->
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable
("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name))
(* 'can-discard=' specifies which arguments can be discarded without warning
because they are not understood by some versions of OCaml. *)
let can_discard = ref []
let read_one_param ppf position name v =
let set name options s = setter ppf (fun b -> b) name options s in
let clear name options s = setter ppf (fun b -> not b) name options s in
match name with
| "g" -> set "g" [ Clflags.debug ] v
| "p" -> set "p" [ Clflags.gprofile ] v
| "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v
| "annot" -> set "annot" [ Clflags.annotations ] v
| "absname" -> set "absname" [ Location.absname ] v
| "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v
| "noassert" -> set "noassert" [ noassert ] v
| "noautolink" -> set "noautolink" [ no_auto_link ] v
| "nostdlib" -> set "nostdlib" [ no_std_include ] v
| "linkall" -> set "linkall" [ link_everything ] v
| "nolabels" -> set "nolabels" [ classic ] v
| "principal" -> set "principal" [ principal ] v
| "rectypes" -> set "rectypes" [ recursive_types ] v
| "safe-string" -> clear "safe-string" [ unsafe_string ] v
| "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v
| "strict-formats" -> set "strict-formats" [ strict_formats ] v
| "thread" -> set "thread" [ use_threads ] v
| "unsafe" -> set "unsafe" [ fast ] v
| "verbose" -> set "verbose" [ verbose ] v
| "nopervasives" -> set "nopervasives" [ nopervasives ] v
| "slash" -> set "slash" [ force_slash ] v (* for ocamldep *)
| "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v
| "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v
| "compact" -> clear "compact" [ optimize_for_speed ] v
| "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v
| "nodynlink" -> clear "nodynlink" [ dlcode ] v
| "short-paths" -> clear "short-paths" [ real_paths ] v
| "trans-mod" -> set "trans-mod" [ transparent_modules ] v
| "opaque" -> set "opaque" [ opaque ] v
| "pp" -> preprocessor := Some v
| "runtime-variant" -> runtime_variant := v
| "cc" -> c_compiler := Some v
| "clambda-checks" -> set "clambda-checks" [ clambda_checks ] v
(* assembly sources *)
| "s" ->
set "s" [ Clflags.keep_asm_file ; Clflags.keep_startup_file ] v
| "S" -> set "S" [ Clflags.keep_asm_file ] v
| "dstartup" -> set "dstartup" [ Clflags.keep_startup_file ] v
(* warn-errors *)
| "we" | "warn-error" -> Warnings.parse_options true v
(* warnings *)
| "w" -> Warnings.parse_options false v
(* warn-errors *)
| "wwe" -> Warnings.parse_options false v
(* inlining *)
| "inline" ->
let module F = Float_arg_helper in
begin match F.parse_no_error v inline_threshold with
| F.Ok -> ()
| F.Parse_failed exn ->
let error =
Printf.sprintf "bad syntax for \"inline\": %s"
(Printexc.to_string exn)
in
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable ("OCAMLPARAM", error))
end
| "inline-toplevel" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-toplevel'"
inline_toplevel_threshold
| "rounds" -> int_setter ppf "rounds" simplify_rounds v
| "unroll" ->
Int_arg_helper.parse v "Bad syntax in OCAMLPARAM for 'unroll'"
unroll
| "inline-call-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-call-cost'"
inline_call_cost
| "inline-alloc-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-alloc-cost'"
inline_alloc_cost
| "inline-prim-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-prim-cost'"
inline_prim_cost
| "inline-branch-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-branch-cost'"
inline_branch_cost
| "inline-indirect-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-indirect-cost'"
inline_indirect_cost
| "inline-lifting-benefit" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-lifting-benefit'"
inline_lifting_benefit
| "branch-inline-factor" ->
Float_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'branch-inline-factor'"
branch_inline_factor
| "max-inlining-depth" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'max-inlining-depth'"
max_inlining_depth
| "classic-inlining" ->
set "classic-inlining" [ classic_inlining ] v
| "O2" ->
set "O2" [ o2 ] v
| "O3" ->
set "O3" [ o3 ] v
| "unbox-closures" ->
set "unbox-closures" [ unbox_closures ] v
| "remove-unused-arguments" ->
set "remove-unused-arguments" [ remove_unused_arguments ] v
| "no-inline-recursive-functions" ->
clear "no-inline-recursive-functions" [ inline_recursive_functions ] v
| "inlining-report" ->
if !native_code then
set "inlining-report" [ inlining_stats ] v
| "flambda-verbose" ->
set "flambda-verbose" [ dump_flambda_verbose ] v
| "flambda-invariants" ->
set "flambda-invariants" [ flambda_invariant_checks ] v
(* color output *)
| "color" ->
begin match parse_color_setting v with
| None ->
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable ("OCAMLPARAM",
"bad value for \"color\", \
(expected \"auto\", \"always\" or \"never\")"))
| Some setting -> color := setting
end
| "intf-suffix" -> Config.interface_suffix := v
| "I" -> begin
match position with
| Before_args -> first_include_dirs := v :: !first_include_dirs
| Before_link | Before_compile _ ->
last_include_dirs := v :: !last_include_dirs
end
| "cclib" ->
begin
match position with
| Before_compile _ -> ()
| Before_link | Before_args ->
ccobjs := Misc.rev_split_words v @ !ccobjs
end
| "ccopts" ->
begin
match position with
| Before_link | Before_compile _ ->
last_ccopts := v :: !last_ccopts
| Before_args ->
first_ccopts := v :: !first_ccopts
end
| "ppx" ->
begin
match position with
| Before_link | Before_compile _ ->
last_ppx := v :: !last_ppx
| Before_args ->
first_ppx := v :: !first_ppx
end
| "cmo" | "cma" ->
if not !native_code then
begin
match position with
| Before_link | Before_compile _ ->
last_objfiles := v ::! last_objfiles
| Before_args ->
first_objfiles := v :: !first_objfiles
end
| "cmx" | "cmxa" ->
if !native_code then
begin
match position with
| Before_link | Before_compile _ ->
last_objfiles := v ::! last_objfiles
| Before_args ->
first_objfiles := v :: !first_objfiles
end
| "pic" ->
if !native_code then
set "pic" [ pic_code ] v
| "can-discard" ->
can_discard := v ::!can_discard
| "timings" -> set "timings" [ print_timings ] v
| _ ->
if not (List.mem name !can_discard) then begin
can_discard := name :: !can_discard;
Printf.eprintf
"Warning: discarding value of variable %S in OCAMLPARAM\n%!"
name
end
let read_OCAMLPARAM ppf position =
try
let s = Sys.getenv "OCAMLPARAM" in
@ -153,159 +386,105 @@ let read_OCAMLPARAM ppf position =
(Warnings.Bad_env_variable ("OCAMLPARAM", s));
[],[]
in
let set name options s = setter ppf (fun b -> b) name options s in
let clear name options s = setter ppf (fun b -> not b) name options s in
List.iter (fun (name, v) ->
match name with
| "g" -> set "g" [ Clflags.debug ] v
| "p" -> set "p" [ Clflags.gprofile ] v
| "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v
| "annot" -> set "annot" [ Clflags.annotations ] v
| "absname" -> set "absname" [ Location.absname ] v
| "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v
| "noassert" -> set "noassert" [ noassert ] v
| "noautolink" -> set "noautolink" [ no_auto_link ] v
| "nostdlib" -> set "nostdlib" [ no_std_include ] v
| "linkall" -> set "linkall" [ link_everything ] v
| "nolabels" -> set "nolabels" [ classic ] v
| "principal" -> set "principal" [ principal ] v
| "rectypes" -> set "rectypes" [ recursive_types ] v
| "safe-string" -> clear "safe-string" [ unsafe_string ] v
| "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v
| "strict-formats" -> set "strict-formats" [ strict_formats ] v
| "thread" -> set "thread" [ use_threads ] v
| "unsafe" -> set "unsafe" [ fast ] v
| "verbose" -> set "verbose" [ verbose ] v
| "nopervasives" -> set "nopervasives" [ nopervasives ] v
| "slash" -> set "slash" [ force_slash ] v (* for ocamldep *)
| "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v
| "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v
| "compact" -> clear "compact" [ optimize_for_speed ] v
| "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v
| "nodynlink" -> clear "nodynlink" [ dlcode ] v
| "short-paths" -> clear "short-paths" [ real_paths ] v
| "trans-mod" -> set "trans-mod" [ transparent_modules ] v
| "pp" -> preprocessor := Some v
| "runtime-variant" -> runtime_variant := v
| "cc" -> c_compiler := Some v
(* assembly sources *)
| "s" ->
set "s" [ Clflags.keep_asm_file ; Clflags.keep_startup_file ] v
| "S" -> set "S" [ Clflags.keep_asm_file ] v
| "dstartup" -> set "dstartup" [ Clflags.keep_startup_file ] v
(* warn-errors *)
| "we" | "warn-error" -> Warnings.parse_options true v
(* warnings *)
| "w" -> Warnings.parse_options false v
(* warn-errors *)
| "wwe" -> Warnings.parse_options false v
(* inlining *)
| "inline" -> begin try
inline_threshold := 8 * int_of_string v
with _ ->
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable ("OCAMLPARAM",
"non-integer parameter for \"inline\""))
end
(* color output *)
| "color" ->
begin match parse_color_setting v with
| None ->
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable ("OCAMLPARAM",
"bad value for \"color\", \
(expected \"auto\", \"always\" or \"never\")"))
| Some setting -> color := setting
end
| "intf-suffix" -> Config.interface_suffix := v
| "I" -> begin
match position with
| Before_args -> first_include_dirs := v :: !first_include_dirs
| Before_link | Before_compile ->
last_include_dirs := v :: !last_include_dirs
end
| "cclib" ->
begin
match position with
| Before_compile -> ()
| Before_link | Before_args ->
ccobjs := Misc.rev_split_words v @ !ccobjs
end
| "ccopts" ->
begin
match position with
| Before_link | Before_compile ->
last_ccopts := v :: !last_ccopts
| Before_args ->
first_ccopts := v :: !first_ccopts
end
| "ppx" ->
begin
match position with
| Before_link | Before_compile ->
last_ppx := v :: !last_ppx
| Before_args ->
first_ppx := v :: !first_ppx
end
| "cmo" | "cma" ->
if not !native_code then
begin
match position with
| Before_link | Before_compile ->
last_objfiles := v ::! last_objfiles
| Before_args ->
first_objfiles := v :: !first_objfiles
end
| "cmx" | "cmxa" ->
if !native_code then
begin
match position with
| Before_link | Before_compile ->
last_objfiles := v ::! last_objfiles
| Before_args ->
first_objfiles := v :: !first_objfiles
end
| "pic" ->
if !native_code then
set "pic" [ pic_code ] v
| "can-discard" ->
can_discard := v ::!can_discard
| "timings" -> set "timings" [ print_timings ] v
| _ ->
if not (List.mem name !can_discard) then begin
can_discard := name :: !can_discard;
Printf.eprintf
"Warning: discarding value of variable %S in OCAMLPARAM\n%!"
name
end
) (match position with
Before_args -> before
| Before_compile | Before_link -> after)
List.iter (fun (name, v) -> read_one_param ppf position name v)
(match position with
Before_args -> before
| Before_compile _ | Before_link -> after)
with Not_found -> ()
(* OCAMLPARAM passed as file *)
type pattern =
| Filename of string
| Any
type file_option = {
pattern : pattern;
name : string;
value : string;
}
let scan_line ic =
Scanf.bscanf ic "%[0-9a-zA-Z_.*] : %[a-zA-Z_-] = %s "
(fun pattern name value ->
let pattern =
match pattern with
| "*" -> Any
| _ -> Filename pattern
in
{ pattern; name; value })
let load_config ppf filename =
match open_in_bin filename with
| exception e ->
Location.print_error ppf (Location.in_file filename);
Format.fprintf ppf "Cannot open file %s@." (Printexc.to_string e);
raise Exit
| ic ->
let sic = Scanf.Scanning.from_channel ic in
let rec read line_number line_start acc =
match scan_line sic with
| exception End_of_file ->
close_in ic;
acc
| exception Scanf.Scan_failure error ->
let position = Lexing.{
pos_fname = filename;
pos_lnum = line_number;
pos_bol = line_start;
pos_cnum = pos_in ic;
}
in
let loc = Location.{
loc_start = position;
loc_end = position;
loc_ghost = false;
}
in
Location.print_error ppf loc;
Format.fprintf ppf "Configuration file error %s@." error;
close_in ic;
raise Exit
| line ->
read (line_number + 1) (pos_in ic) (line :: acc)
in
let lines = read 0 0 [] in
lines
let matching_filename filename { pattern } =
match pattern with
| Any -> true
| Filename pattern ->
let filename = String.lowercase_ascii filename in
let pattern = String.lowercase_ascii pattern in
filename = pattern
let apply_config_file ppf position =
let config_file =
Filename.concat Config.standard_library "ocaml_compiler_internal_params"
in
let config =
if Sys.file_exists config_file then
load_config ppf config_file
else
[]
in
let config =
match position with
| Before_compile filename ->
List.filter (matching_filename filename) config
| Before_args | Before_link ->
List.filter (fun { pattern } -> pattern = Any) config
in
List.iter (fun { name; value } -> read_one_param ppf position name value)
config
let readenv ppf position =
last_include_dirs := [];
last_ccopts := [];
last_ppx := [];
last_objfiles := [];
apply_config_file ppf position;
read_OCAMLPARAM ppf position;
all_ccopts := !last_ccopts @ !first_ccopts;
all_ppx := !last_ppx @ !first_ppx

4
driver/compenv.mli
View File

@ -30,8 +30,10 @@ val implicit_modules : string list ref
(* return the list of objfiles, after OCAMLPARAM and List.rev *)
val get_objfiles : unit -> string list
type filename = string
type readenv_position =
Before_args | Before_compile | Before_link
Before_args | Before_compile of filename | Before_link
val readenv : Format.formatter -> readenv_position -> unit

6
driver/main.ml
View File

@ -54,11 +54,11 @@ let ppf = Format.err_formatter
(* Error messages to standard error formatter *)
let anonymous filename =
readenv ppf Before_compile; process_file ppf filename;;
readenv ppf (Before_compile filename); process_file ppf filename;;
let impl filename =
readenv ppf Before_compile; process_implementation_file ppf filename;;
readenv ppf (Before_compile filename); process_implementation_file ppf filename;;
let intf filename =
readenv ppf Before_compile; process_interface_file ppf filename;;
readenv ppf (Before_compile filename); process_interface_file ppf filename;;
let show_config () =
Config.print_config stdout;

204
driver/main_args.ml
View File

@ -43,6 +43,10 @@ let mk_ccopt f =
"<opt> Pass option <opt> to the C compiler and linker"
;;
let mk_clambda_checks f =
"-clambda-checks", Arg.Unit f, " Instrument clambda code with closure and field access checks (for debugging the compiler)"
;;
let mk_compact f =
"-compact", Arg.Unit f, " Optimize code size rather than speed"
;;
@ -110,7 +114,91 @@ let mk_init f =
;;
let mk_inline f =
"-inline", Arg.Int f, "<n> Set aggressiveness of inlining to <n>"
"-inline", Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] Aggressiveness of inlining \
(default %.02f, higher numbers mean more aggressive)"
Clflags.default_inline_threshold
;;
let mk_inline_toplevel f =
"-inline-toplevel", Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] Aggressiveness of inlining at \
toplevel (higher numbers mean more aggressive)"
;;
let mk_inlining_stats f =
"-inlining-report", Arg.Unit f, " Emit `.<round>.inlining' file(s) (one per \
round) showing the inliner's decisions"
;;
let mk_dump_pass f =
"-dump-pass", Arg.String f,
Format.asprintf " Record transformations performed by these passes: %a"
(Format.pp_print_list Format.pp_print_string)
!Clflags.all_passes
;;
let mk_o2 f =
"-O2", Arg.Unit f, " Apply increased optimization for speed"
;;
let mk_o3 f =
"-O3", Arg.Unit f, " Apply aggressive optimization for speed (may \
significantly increase code size and compilation time)"
;;
let mk_rounds f =
"-rounds", Arg.Int f,
Printf.sprintf "<n> Repeat tree optimization and inlining phases this \
many times (default %d). Rounds are numbered starting from zero."
!Clflags.simplify_rounds
;;
let mk_unroll f =
"-unroll", Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] Unroll recursive functions at most this many times \
(default %d)"
Clflags.default_unroll
;;
let mk_classic_inlining f =
"-classic-inlining", Arg.Unit f, " Make inlining decisions at function definition time \
rather than at the call site (replicates previous behaviour of the compiler)"
;;
let mk_inline_cost arg descr default f =
Printf.sprintf "-inline-%s-cost" arg,
Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] The cost of not removing %s during inlining \
(default %d, higher numbers more costly)"
descr
default
;;
let mk_inline_call_cost =
mk_inline_cost "call" "a call" Clflags.default_inline_call_cost
let mk_inline_alloc_cost =
mk_inline_cost "alloc" "an allocation" Clflags.default_inline_alloc_cost
let mk_inline_prim_cost =
mk_inline_cost "prim" "a primitive" Clflags.default_inline_prim_cost
let mk_inline_branch_cost =
mk_inline_cost "branch" "a conditional" Clflags.default_inline_branch_cost
let mk_inline_indirect_cost =
mk_inline_cost "indirect" "an indirect call" Clflags.default_inline_indirect_cost
let mk_inline_lifting_benefit f =
"-inline-lifting-benefit",
Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] The benefit of lifting definitions \
to toplevel during inlining (default %d, higher numbers more beneficial)"
Clflags.default_inline_lifting_benefit
;;
let mk_branch_inline_factor f =
"-branch-inline-factor", Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] Estimate the probability of a \
branch being cold as 1/(1+n) (used for inlining) (default %.2f)"
Clflags.default_branch_inline_factor
;;
let mk_intf f =
@ -151,6 +239,13 @@ let mk_make_runtime_2 f =
"-make_runtime", Arg.Unit f, " (deprecated) same as -make-runtime"
;;
let mk_max_inlining_depth f =
"-max-inlining-depth", Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] Maximum depth of search for inlining opportunities \
inside inlined functions (default %d)"
Clflags.default_max_inlining_depth
;;
let mk_modern f =
"-modern", Arg.Unit f, " (deprecated) same as -labels"
;;
@ -196,6 +291,11 @@ let mk_noinit f =
"-noinit", Arg.Unit f,
" Do not load any init file"
let mk_no_inline_recursive_functions f =
"-no-inline-recursive-functions", Arg.Unit f,
" Do not duplicate and specialise declarations of recursive functions"
;;
let mk_nolabels f =
"-nolabels", Arg.Unit f, " Ignore non-optional labels in types"
;;
@ -261,6 +361,11 @@ let mk_rectypes f =
"-rectypes", Arg.Unit f, " Allow arbitrary recursive types"
;;
let mk_remove_unused_arguments f =
"-remove-unused-arguments", Arg.Unit f,
" Remove unused function arguments (experimental)"
;;
let mk_runtime_variant f =
"-runtime-variant", Arg.String f,
"<str> Use the <str> variant of the run-time system"
@ -300,6 +405,11 @@ let mk_dtimings f =
"-dtimings", Arg.Unit f, " Print timings"
;;
let mk_unbox_closures f =
"-unbox-closures", Arg.Unit f,
" Unbox closures into function arguments (experimental)"
;;
let mk_unsafe f =
"-unsafe", Arg.Unit f,
" Do not compile bounds checking on array and string access"
@ -417,10 +527,30 @@ let mk_dlambda f =
"-dlambda", Arg.Unit f, " (undocumented)"
;;
let mk_drawclambda f =
"-drawclambda", Arg.Unit f, " (undocumented)"
;;
let mk_dclambda f =
"-dclambda", Arg.Unit f, " (undocumented)"
;;
let mk_dflambda f =
"-dflambda", Arg.Unit f, " Print Flambda terms"
;;
let mk_dflambda_invariants f =
"-dflambda-invariants", Arg.Unit f, " Check Flambda invariants around each pass"
;;
let mk_dflambda_let f =
"-dflambda-let", Arg.Int f, "<stamp> Print when the given Flambda [Let] is created"
;;
let mk_dflambda_verbose f =
"-dflambda-verbose", Arg.Unit f, " Print Flambda terms including around each pass"
;;
let mk_dinstr f =
"-dinstr", Arg.Unit f, " (undocumented)"
;;
@ -605,8 +735,33 @@ end;;
module type Optcommon_options = sig
val _compact : unit -> unit
val _inline : int -> unit
val _inline : string -> unit
val _inline_toplevel : string -> unit
val _inlining_stats : unit -> unit
val _dump_pass : string -> unit
val _max_inlining_depth : string -> unit
val _rounds : int -> unit
val _unroll : string -> unit
val _classic_inlining : unit -> unit
val _inline_call_cost : string -> unit
val _inline_alloc_cost : string -> unit
val _inline_prim_cost : string -> unit
val _inline_branch_cost : string -> unit
val _inline_indirect_cost : string -> unit
val _inline_lifting_benefit : string -> unit
val _unbox_closures : unit -> unit
val _branch_inline_factor : string -> unit
val _no_inline_recursive_functions : unit -> unit
val _remove_unused_arguments : unit -> unit
val _o2 : unit -> unit
val _o3 : unit -> unit
val _clambda_checks : unit -> unit
val _dflambda : unit -> unit
val _dflambda_invariants : unit -> unit
val _dflambda_let : int -> unit
val _dflambda_verbose : unit -> unit
val _drawclambda : unit -> unit
val _dclambda : unit -> unit
val _dcmm : unit -> unit
val _dsel : unit -> unit
@ -801,10 +956,13 @@ struct
mk_absname F._absname;
mk_annot F._annot;
mk_binannot F._binannot;
mk_branch_inline_factor F._branch_inline_factor;
mk_c F._c;
mk_cc F._cc;
mk_cclib F._cclib;
mk_ccopt F._ccopt;
mk_clambda_checks F._clambda_checks;
mk_classic_inlining F._classic_inlining;
mk_color F._color;
mk_compact F._compact;
mk_config F._config;
@ -815,21 +973,33 @@ struct
mk_I F._I;
mk_impl F._impl;
mk_inline F._inline;
mk_inline_toplevel F._inline_toplevel;
mk_inline_alloc_cost F._inline_alloc_cost;
mk_inline_branch_cost F._inline_branch_cost;
mk_inline_call_cost F._inline_call_cost;
mk_inline_prim_cost F._inline_prim_cost;
mk_inline_indirect_cost F._inline_indirect_cost;
mk_inline_lifting_benefit F._inline_lifting_benefit;
mk_inlining_stats F._inlining_stats;
mk_intf F._intf;
mk_intf_suffix F._intf_suffix;
mk_keep_docs F._keep_docs;
mk_keep_locs F._keep_locs;
mk_labels F._labels;
mk_linkall F._linkall;
mk_max_inlining_depth F._max_inlining_depth;
mk_no_alias_deps F._no_alias_deps;
mk_no_app_funct F._no_app_funct;
mk_no_float_const_prop F._no_float_const_prop;
mk_noassert F._noassert;
mk_noautolink_opt F._noautolink;
mk_nodynlink F._nodynlink;
mk_no_inline_recursive_functions F._no_inline_recursive_functions;
mk_nolabels F._nolabels;
mk_nostdlib F._nostdlib;
mk_o F._o;
mk_o2 F._o2;
mk_o3 F._o3;
mk_open F._open;
mk_output_obj F._output_obj;
mk_output_complete_obj F._output_complete_obj;
@ -839,6 +1009,8 @@ struct
mk_ppx F._ppx;
mk_principal F._principal;
mk_rectypes F._rectypes;
mk_remove_unused_arguments F._remove_unused_arguments;
mk_rounds F._rounds;
mk_runtime_variant F._runtime_variant;
mk_S F._S;
mk_safe_string F._safe_string;
@ -847,6 +1019,8 @@ struct
mk_strict_sequence F._strict_sequence;
mk_strict_formats F._strict_formats;
mk_thread F._thread;
mk_unbox_closures F._unbox_closures;
mk_unroll F._unroll;
mk_unsafe F._unsafe;
mk_unsafe_string F._unsafe_string;
mk_v F._v;
@ -866,7 +1040,12 @@ struct
mk_dtypedtree F._dtypedtree;
mk_drawlambda F._drawlambda;
mk_dlambda F._dlambda;
mk_drawclambda F._drawclambda;
mk_dclambda F._dclambda;
mk_dflambda F._dflambda;
mk_dflambda_invariants F._dflambda_invariants;
mk_dflambda_let F._dflambda_let;
mk_dflambda_verbose F._dflambda_verbose;
mk_dcmm F._dcmm;
mk_dsel F._dsel;
mk_dcombine F._dcombine;
@ -882,6 +1061,7 @@ struct
mk_dlinear F._dlinear;
mk_dstartup F._dstartup;
mk_dtimings F._dtimings;
mk_dump_pass F._dump_pass;
mk_opaque F._opaque;
]
end;;
@ -893,25 +1073,42 @@ module Make_opttop_options (F : Opttop_options) = struct
mk_I F._I;
mk_init F._init;
mk_inline F._inline;
mk_inline_toplevel F._inline_toplevel;
mk_inlining_stats F._inlining_stats;
mk_rounds F._rounds;
mk_unroll F._unroll;
mk_classic_inlining F._classic_inlining;
mk_inline_call_cost F._inline_call_cost;
mk_inline_alloc_cost F._inline_alloc_cost;
mk_inline_prim_cost F._inline_prim_cost;
mk_inline_branch_cost F._inline_branch_cost;
mk_inline_indirect_cost F._inline_indirect_cost;
mk_inline_lifting_benefit F._inline_lifting_benefit;
mk_branch_inline_factor F._branch_inline_factor;
mk_labels F._labels;
mk_no_alias_deps F._no_alias_deps;
mk_no_app_funct F._no_app_funct;
mk_noassert F._noassert;
mk_noinit F._noinit;
mk_no_inline_recursive_functions F._no_inline_recursive_functions;
mk_nolabels F._nolabels;
mk_noprompt F._noprompt;
mk_nopromptcont F._nopromptcont;
mk_nostdlib F._nostdlib;
mk_o2 F._o2;
mk_o3 F._o3;
mk_open F._open;
mk_ppx F._ppx;
mk_principal F._principal;
mk_rectypes F._rectypes;
mk_remove_unused_arguments F._remove_unused_arguments;
mk_S F._S;
mk_safe_string F._safe_string;
mk_short_paths F._short_paths;
mk_stdin F._stdin;
mk_strict_sequence F._strict_sequence;
mk_strict_formats F._strict_formats;
mk_unbox_closures F._unbox_closures;
mk_unsafe F._unsafe;
mk_unsafe_string F._unsafe_string;
mk_version F._version;
@ -926,7 +1123,9 @@ module Make_opttop_options (F : Opttop_options) = struct
mk_dparsetree F._dparsetree;
mk_dtypedtree F._dtypedtree;
mk_drawlambda F._drawlambda;
mk_drawclambda F._drawclambda;
mk_dclambda F._dclambda;
mk_dflambda F._dflambda;
mk_dcmm F._dcmm;
mk_dsel F._dsel;
mk_dcombine F._dcombine;
@ -941,6 +1140,7 @@ module Make_opttop_options (F : Opttop_options) = struct
mk_dscheduling F._dscheduling;
mk_dlinear F._dlinear;
mk_dstartup F._dstartup;
mk_dump_pass F._dump_pass;
]
end;;

27
driver/main_args.mli
View File

@ -117,8 +117,33 @@ end;;
module type Optcommon_options = sig
val _compact : unit -> unit
val _inline : int -> unit
val _inline : string -> unit
val _inline_toplevel : string -> unit
val _inlining_stats : unit -> unit
val _dump_pass : string -> unit
val _max_inlining_depth : string -> unit
val _rounds : int -> unit
val _unroll : string -> unit
val _classic_inlining : unit -> unit
val _inline_call_cost : string -> unit
val _inline_alloc_cost : string -> unit
val _inline_prim_cost : string -> unit
val _inline_branch_cost : string -> unit
val _inline_indirect_cost : string -> unit
val _inline_lifting_benefit : string -> unit
val _unbox_closures : unit -> unit
val _branch_inline_factor : string -> unit
val _no_inline_recursive_functions : unit -> unit
val _remove_unused_arguments : unit -> unit
val _o2 : unit -> unit
val _o3 : unit -> unit
val _clambda_checks : unit -> unit
val _dflambda : unit -> unit
val _dflambda_invariants : unit -> unit
val _dflambda_let : int -> unit
val _dflambda_verbose : unit -> unit
val _drawclambda : unit -> unit
val _dclambda : unit -> unit
val _dcmm : unit -> unit
val _dsel : unit -> unit

63
driver/optcompile.ml
View File

@ -58,7 +58,7 @@ let print_if ppf flag printer arg =
let (++) x f = f x
let (+++) (x, y) f = (x, f y)
let implementation ppf sourcefile outputprefix =
let implementation ppf sourcefile outputprefix ~backend =
let source_provenance = Timings.File sourcefile in
Compmisc.init_path true;
let modulename = module_of_filename ppf sourcefile outputprefix in
@ -75,19 +75,58 @@ let implementation ppf sourcefile outputprefix =
++ Timings.(time (Typing sourcefile))
(Typemod.type_implementation sourcefile outputprefix modulename env)
++ print_if ppf Clflags.dump_typedtree
Printtyped.implementation_with_coercion
Printtyped.implementation_with_coercion
in
if not !Clflags.print_types then begin
(typedtree, coercion)
++ Timings.(time (Transl sourcefile))
(Translmod.transl_store_implementation modulename)
+++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
++ Timings.(time (Generate sourcefile))
(fun (size, lambda) ->
(size, Simplif.simplify_lambda lambda)
+++ print_if ppf Clflags.dump_lambda Printlambda.lambda
++ Asmgen.compile_implementation ~source_provenance outputprefix ppf;
Compilenv.save_unit_info cmxfile)
if Config.flambda then begin
if !Clflags.o3 then begin
Clflags.simplify_rounds := 3;
Clflags.use_inlining_arguments_set ~round:0 Clflags.o1_arguments;
Clflags.use_inlining_arguments_set ~round:1 Clflags.o2_arguments;
Clflags.use_inlining_arguments_set ~round:2 Clflags.o3_arguments
end
else if !Clflags.o2 then begin
Clflags.simplify_rounds := 2;
Clflags.use_inlining_arguments_set ~round:0 Clflags.o1_arguments;
Clflags.use_inlining_arguments_set ~round:1 Clflags.o2_arguments
end
else if !Clflags.classic_inlining then begin
Clflags.use_inlining_arguments_set Clflags.classic_arguments
end;
(typedtree, coercion)
++ Timings.(time (Timings.Transl sourcefile)
(Translmod.transl_implementation_flambda modulename))
+++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
++ Timings.time (Timings.Generate sourcefile) (fun lambda ->
lambda
+++ Simplif.simplify_lambda
+++ print_if ppf Clflags.dump_lambda Printlambda.lambda
++ (fun ((module_ident, size), lam) ->
Middle_end.middle_end ppf ~source_provenance
~prefixname:outputprefix
~size
~module_ident
~backend
~module_initializer:lam)
++ Asmgen.compile_implementation_flambda ~source_provenance
outputprefix ~backend ppf;
Compilenv.save_unit_info cmxfile)
end
else begin
Clflags.use_inlining_arguments_set Clflags.classic_arguments;
(typedtree, coercion)
++ Timings.(time (Transl sourcefile))
(Translmod.transl_store_implementation modulename)
++ print_if ppf Clflags.dump_rawlambda Printlambda.program
++ Timings.(time (Generate sourcefile))
(fun { Lambda.code; main_module_block_size } ->
{ Lambda.code = Simplif.simplify_lambda code;
main_module_block_size }
++ print_if ppf Clflags.dump_lambda Printlambda.program
++ Asmgen.compile_implementation_clambda ~source_provenance
outputprefix ppf;
Compilenv.save_unit_info cmxfile)
end
end;
Warnings.check_fatal ();
Stypes.dump (Some (outputprefix ^ ".annot"))

9
driver/optcompile.mli
View File

@ -15,5 +15,12 @@
open Format
val interface: formatter -> string -> string -> unit
val implementation: formatter -> string -> string -> unit
val implementation
: formatter
-> string
-> string
-> backend:(module Backend_intf.S)
-> unit
val c_file: string -> unit

86
driver/optmain.ml
View File

@ -14,6 +14,24 @@ open Config
open Clflags
open Compenv
module Backend = struct
(* See backend_intf.mli. *)
let symbol_for_global' = Compilenv.symbol_for_global'
let closure_symbol = Compilenv.closure_symbol
let really_import_approx = Import_approx.really_import_approx
let import_symbol = Import_approx.import_symbol
let size_int = Arch.size_int
let big_endian = Arch.big_endian
(* CR mshinwell: this needs tying through to [Proc], although it may
necessitate the introduction of a new field in that module. *)
let max_sensible_number_of_arguments = 9
end
let backend = (module Backend : Backend_intf.S)
let process_interface_file ppf name =
let opref = output_prefix name in
Optcompile.interface ppf name opref;
@ -21,7 +39,7 @@ let process_interface_file ppf name =
let process_implementation_file ppf name =
let opref = output_prefix name in
Optcompile.implementation ppf name opref;
Optcompile.implementation ppf name opref ~backend;
objfiles := (opref ^ ".cmx") :: !objfiles
let cmxa_present = ref false;;
@ -56,11 +74,11 @@ let ppf = Format.err_formatter
(* Error messages to standard error formatter *)
let anonymous filename =
readenv ppf Before_compile; process_file ppf filename;;
readenv ppf (Before_compile filename); process_file ppf filename;;
let impl filename =
readenv ppf Before_compile; process_implementation_file ppf filename;;
readenv ppf (Before_compile filename); process_implementation_file ppf filename;;
let intf filename =
readenv ppf Before_compile; process_interface_file ppf filename;;
readenv ppf (Before_compile filename); process_interface_file ppf filename;;
let show_config () =
Config.print_config stdout;
@ -79,6 +97,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _cc s = c_compiler := Some s
let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
let _ccopt s = first_ccopts := s :: !first_ccopts
let _clambda_checks () = clambda_checks := true
let _compact = clear optimize_for_speed
let _config () = show_config ()
let _for_pack s = for_package := Some s
@ -86,32 +105,75 @@ module Options = Main_args.Make_optcomp_options (struct
let _i () = print_types := true; compile_only := true
let _I dir = include_dirs := dir :: !include_dirs
let _impl = impl
let _inline n = inline_threshold := n * 8
let _inline spec =
Float_arg_helper.parse spec ~update:inline_threshold
~help_text:"Syntax: -inline <n> | <round>=<n>[,...]"
let _inline_toplevel spec =
Int_arg_helper.parse spec ~update:inline_toplevel_threshold
~help_text:"Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
let _inlining_stats () = inlining_stats := true
let _dump_pass pass = set_dumped_pass pass true
let _rounds n = simplify_rounds := n
let _unroll spec =
Int_arg_helper.parse spec ~update:unroll
~help_text:"Syntax: -unroll <n> | <round>=<n>[,...]"
let _classic_inlining () = classic_inlining := true
let _inline_call_cost spec =
Int_arg_helper.parse spec ~update:inline_call_cost
~help_text:"Syntax: -inline-call-cost <n> | <round>=<n>[,...]"
let _inline_alloc_cost spec =
Int_arg_helper.parse spec ~update:inline_alloc_cost
~help_text:"Syntax: -inline-alloc-cost <n> | <round>=<n>[,...]"
let _inline_prim_cost spec =
Int_arg_helper.parse spec ~update:inline_prim_cost
~help_text:"Syntax: -inline-prim-cost <n> | <round>=<n>[,...]"
let _inline_branch_cost spec =
Int_arg_helper.parse spec ~update:inline_branch_cost
~help_text:"Syntax: -inline-branch-cost <n> | <round>=<n>[,...]"
let _inline_indirect_cost spec =
Int_arg_helper.parse spec ~update:inline_indirect_cost
~help_text:"Syntax: -inline-indirect-cost <n> | <round>=<n>[,...]"
let _inline_lifting_benefit spec =
Int_arg_helper.parse spec ~update:inline_lifting_benefit
~help_text:"Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
let _branch_inline_factor spec =
Float_arg_helper.parse spec ~update:branch_inline_factor
~help_text:"Syntax: -branch-inline-factor <n> | <round>=<n>[,...]"
let _intf = intf
let _intf_suffix s = Config.interface_suffix := s
let _keep_docs = set keep_docs
let _keep_locs = set keep_locs
let _labels = clear classic
let _linkall = set link_everything
let _max_inlining_depth spec =
Int_arg_helper.parse spec ~update:max_inlining_depth
~help_text:"Syntax: -max-inlining-depth <n> | <round>=<n>[,...]"
let _no_alias_deps = set transparent_modules
let _no_app_funct = clear applicative_functors
let _no_float_const_prop = clear float_const_prop
let _noassert = set noassert
let _noautolink = set no_auto_link
let _nodynlink = clear dlcode
let _no_inline_recursive_functions = clear inline_recursive_functions
let _nolabels = set classic
let _nostdlib = set no_std_include
let _o s = output_name := Some s
(* CR mshinwell: should stop e.g. -O2 -classic-inlining
lgesbert: could be done in main() below, like for -pack and -c, but that
would prevent overriding using OCAMLPARAM. *)
let _o2 = set o2
let _o3 = set o3
let _open s = open_modules := s :: !open_modules
let _output_obj = set output_c_object
let _output_complete_obj s =
set output_c_object s; set output_complete_object s
let _output_complete_obj () =
set output_c_object (); set output_complete_object ()
let _p = set gprofile
let _pack = set make_package
let _pp s = preprocessor := Some s
let _ppx s = first_ppx := s :: !first_ppx
let _principal = set principal
let _rectypes = set recursive_types
let _remove_unused_arguments = set remove_unused_arguments
let _runtime_variant s = runtime_variant := s
let _safe_string = clear unsafe_string
let _short_paths = clear real_paths
@ -120,6 +182,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _shared () = shared := true; dlcode := true
let _S = set keep_asm_file
let _thread = set use_threads
let _unbox_closures = set unbox_closures
let _unsafe = set fast
let _unsafe_string = set unsafe_string
let _v () = print_version_and_library "native-code compiler"
@ -142,7 +205,14 @@ module Options = Main_args.Make_optcomp_options (struct
let _dtypedtree = set dump_typedtree
let _drawlambda = set dump_rawlambda
let _dlambda = set dump_lambda
let _drawclambda = set dump_rawclambda
let _dclambda = set dump_clambda
let _dflambda = set dump_flambda
let _dflambda_let stamp = dump_flambda_let := Some stamp
let _dflambda_verbose () =
set dump_flambda ();
set dump_flambda_verbose ()
let _dflambda_invariants = set flambda_invariant_checks
let _dcmm = set dump_cmm
let _dsel = set dump_selection
let _dcombine = set dump_combine
@ -188,7 +258,7 @@ let main () =
Compmisc.init_path true;
let target = extract_output !output_name in
Asmpackager.package_files ppf (Compmisc.initial_env ())
(get_objfiles ()) target;
(get_objfiles ()) target ~backend;
Warnings.check_fatal ();
end
else if !shared then begin

15
driver/pparse.ml
View File

@ -145,7 +145,7 @@ let open_and_check_magic inputfile ast_magic =
in
(ic, is_ast_file)
let file ppf ~tool_name inputfile parse_fun ast_magic =
let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic =
let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
let ast =
try
@ -166,7 +166,12 @@ let file ppf ~tool_name inputfile parse_fun ast_magic =
with x -> close_in ic; raise x
in
close_in ic;
apply_rewriters ~restore:false ~tool_name ast_magic ast
let ast = apply_rewriters ~restore:false ~tool_name ast_magic ast in
if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
ast
let file ppf ~tool_name inputfile parse_fun ast_magic =
file_aux ppf ~tool_name inputfile parse_fun ignore ast_magic
let report_error ppf = function
| CannotRun cmd ->
@ -183,11 +188,11 @@ let () =
| _ -> None
)
let parse_all ~tool_name parse_fun magic ppf sourcefile =
let parse_all ~tool_name parse_fun invariant_fun magic ppf sourcefile =
Location.input_name := sourcefile;
let inputfile = preprocess sourcefile in
let ast =
try file ppf ~tool_name inputfile parse_fun magic
try file_aux ppf ~tool_name inputfile parse_fun invariant_fun magic
with exn ->
remove_preprocessed inputfile;
raise exn
@ -198,8 +203,10 @@ let parse_all ~tool_name parse_fun magic ppf sourcefile =
let parse_implementation ppf ~tool_name sourcefile =
parse_all ~tool_name
(Timings.(time (Parsing sourcefile)) Parse.implementation)
Ast_invariants.structure
Config.ast_impl_magic_number ppf sourcefile
let parse_interface ppf ~tool_name sourcefile =
parse_all ~tool_name
(Timings.(time (Parsing sourcefile)) Parse.interface)
Ast_invariants.signature
Config.ast_intf_magic_number ppf sourcefile

1
flexdll Submodule

@ -0,0 +1 @@
Subproject commit c041e8beef98484a67df08b2ced27e096b6ea766

4
lex/Makefile.nt
View File

@ -17,7 +17,7 @@ CAMLRUN ?= ../boot/ocamlrun
CAMLYACC ?= ../boot/ocamlyacc
CAMLC=$(CAMLRUN) ../boot/ocamlc -I ../boot
CAMLOPT=$(CAMLRUN) ../ocamlopt -I ../stdlib
CAMLOPT=$(if $(wildcard ../flexdll/Makefile),OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe") $(CAMLRUN) ../ocamlopt -I ../stdlib
COMPFLAGS=-warn-error A
LINKFLAGS=
YACCFLAGS=-v
@ -45,7 +45,7 @@ parser.ml parser.mli: parser.mly
$(CAMLYACC) $(YACCFLAGS) parser.mly
clean::
rm -f parser.ml parser.mli
rm -f parser.ml parser.mli parser.output
beforedepend:: parser.ml parser.mli

3
man/ocamlc.m
View File

@ -855,6 +855,9 @@ mutually recursive types.
50
\ \ Unexpected documentation comment.
59
\ \ Assignment on non-mutable value.
The letters stand for the following sets of warnings. Any letter not
mentioned here corresponds to the empty set.

8
manual/manual/cmds/comp.etex
View File

@ -519,6 +519,14 @@ Display a short usage summary and exit.
%
\end{options}
\noindent
On native Windows, the following environment variable is also consulted:
\begin{options}
\item["OCAML_FLEXLINK"] Alternative executable to use instead of the
configured value. Primarily used for bootstrapping.
\end{options}
\section{Modules and the file system}
This short section is intended to clarify the relationship between the

8
manual/manual/cmds/intf-c.etex
View File

@ -2232,6 +2232,14 @@ libraries are supported) and "lib"\var{outputc}".a".
If not specified, defaults to the output name given with "-o".
\end{options}
\noindent
On native Windows, the following environment variable is also consulted:
\begin{options}
\item["OCAML_FLEXLINK"] Alternative executable to use instead of the
configured value. Primarily used for bootstrapping.
\end{options}
\paragraph{Example} Consider an OCaml interface to the standard "libz"
C library for reading and writing compressed files. Assume this
library resides in "/usr/local/zlib". This interface is

8
manual/manual/cmds/native.etex
View File

@ -505,6 +505,14 @@ Display a short usage summary and exit.
%
\end{options}
\noindent
On native Windows, the following environment variable is also consulted:
\begin{options}
\item["OCAML_FLEXLINK"] Alternative executable to use instead of the
configured value. Primarily used for bootstrapping.
\end{options}
\paragraph{Options for the IA32 architecture}
The IA32 code generator (Intel Pentium, AMD Athlon) supports the
following additional option:

2
middle_end/alias_analysis.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
type allocation_point =
| Symbol of Symbol.t
| Variable of Variable.t

2
middle_end/alias_analysis.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
type allocation_point =
| Symbol of Symbol.t
| Variable of Variable.t

2
middle_end/allocated_const.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
type t =
| Float of float
| Int32 of int32

2
middle_end/allocated_const.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
(** Constants that are always allocated (possibly statically). Blocks
are not included here since they are always encoded using
[Prim (Pmakeblock, ...)]. *)

2
middle_end/augment_closures.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
module A = Simple_value_approx
module E = Inline_and_simplify_aux.Env

2
middle_end/augment_closures.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
val run :
env:Inline_and_simplify_aux.Env.t ->
set_of_closures:Flambda.set_of_closures ->

2
middle_end/backend_intf.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
(** Knowledge that the middle end needs about the backend. *)
module type S = sig

2
middle_end/base_types/closure_element.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
include Variable
let wrap t = t

2
middle_end/base_types/closure_element.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
include Identifiable.S
val wrap : Variable.t -> t

2
middle_end/base_types/closure_id.ml
View File

@ -14,4 +14,6 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
include Closure_element

2
middle_end/base_types/closure_id.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
(** CR-someday lwhite: "Closure_id" is quite a generic name. I wonder wether something
like "Closure_label" would better capture that it is the label of a projection. *)

2
middle_end/base_types/compilation_unit.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
type t = {
id : Ident.t;
linkage_name : Linkage_name.t;

2
middle_end/base_types/compilation_unit.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
include Identifiable.S
(* The [Ident.t] must be persistent. This function raises an exception

2
middle_end/base_types/export_id.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
module Id : Id_types.Id = Id_types.Id (struct end)
module Unit_id = Id_types.UnitId (Id) (Compilation_unit)

2
middle_end/base_types/export_id.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
(* Keys representing value descriptions that may be written into
intermediate files and loaded by a dependent compilation unit.
These keys are used to ensure maximal sharing of value descriptions,

2
middle_end/base_types/id_types.ml
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
module type BaseId = sig
type t
val equal : t -> t -> bool

Some files were not shown because too many files have changed in this diff Show More