diff options
| author | Alain Frisch <alain@frisch.fr> | 2014-04-14 11:52:29 +0000 |
|---|---|---|
| committer | Alain Frisch <alain@frisch.fr> | 2014-04-14 11:52:29 +0000 |
| commit | 6346154d4bc690c7909d5cff4bf7fc1bc57bbcc6 (patch) | |
| tree | 7faa3541ad30d103e071e850f5bfe2f66bfe2e0a | |
| parent | 907c477c02450deb9b452b47599dc1d16806395c (diff) | |
| parent | 5f5bd08abc667d67762e80f1febded27a99842b9 (diff) | |
| download | ocaml-6346154d4bc690c7909d5cff4bf7fc1bc57bbcc6.tar.gz | |
Synchronize with trunk.
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/constructors_with_record3@14587 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
172 files changed, 2279 insertions, 1163 deletions
@@ -1,4 +1,4 @@ -utils/ccomp.cmi : +putils/ccomp.cmi : utils/clflags.cmi : utils/config.cmi : utils/consistbl.cmi : @@ -20,7 +20,7 @@ Other libraries: Type system: * Keep typing of pattern cases independent in principal mode (i.e. information from previous cases is no longer used when typing - patterns; cf. PR6235' in typing-warnings/records.ml) + patterns; cf. 'PR#6235' in testsuite/test/typing-warnings/records.ml) - Allow opening a first-class module or applying a generative functor in the body of a generative functor. Allow it also in the body of an applicative functor if no types are created @@ -78,14 +78,34 @@ Bug fixes: - PR#6062: Fix a regression bug caused by commit 13047 - PR#6109: Typos in ocamlbuild error messages - PR#6116: more efficient implementation of Digest.to_hex (patch by ygrek) +- PR#6165: Alterations to handling of \013 in source files breaking other tools +- PR#6173: Typing error message is worse that before - PR#6174: OCaml compiler loops on an example using GADTs (-rectypes case) +- PR#6175: Fix open! +- PR#6183: enhanced documentation for 'Unix.shutdown_connection' - PR#6184: ocamlbuild: `ocamlfind ocamldep` does not support -predicate (report and patch by Jacques-Pascal Deplaix) +- PR#6194: Incorrect unused warning with first-class modules in patterns +- PR#6216: inlining of GADT matches generates invalid assembly +- PR#6233: out-of-bounds exceptions lose their locations on ARM, PowerPC +- PR#6235: Issue with type information flowing through a variant pattern +- PR#6239: sometimes wrong stack alignment when raising exceptions + in -g mode with backtraces active +- PR#6240: Fail to expand module type abbreviation during substyping +- PR#6241: Assumed inequality between paths involving functor arguments +- PR#6243: Make "ocamlopt -g" more resistant to ill-formed locations - PR#6262: equality of first-class modules take module aliases into account +- PR#6267: more information printed by "bt" command of ocamldebug +- PR#6275: Soundness bug related to type constraints - PR#6293: Assert_failure with invalid package type - PR#6307: Behavior of 'module type of' w.r.t. module aliases +- PR#6346: Build failure with latest version of xcode on OSX +- PR#6348: Unification failure for GADT when original definition is hidden +- PR#6352: Automatic removal of optional arguments and sequencing - fix -dsource printing of "external _pipe = ..." (Gabriel Scherer) +- bound-checking bug in caml_string_{get,set}{16,32,64} + (Pierre Chambart and Gabriel Scherer, report by Nicolas Trangez) Features wishes: - PR#4243: make the Makefiles parallelizable @@ -94,42 +114,24 @@ Features wishes: - PR#5547: Enable the "-use-ocamlfind" option by default - PR#5650: Camlp4FoldGenerator doesn't handle well "abstract" types - PR#5808: allow simple patterns, not only identifiers, in "let p : t = ..." +- PR#6000: add a warning for non-principal coercions to format - PR#6054: add support for M.[ foo ], M.[| foo |] etc. (patch by Kaustuv Chaudhuri) - PR#6064: GADT representation for Bigarray.kind + CAML_BA_CHAR runtime kind - PR#6071: Add a -noinit option to the toplevel (patch by David Sheets) - PR#6166: document -ocamldoc option of ocamlbuild - PR#6187: ocamlbuild: warn when using -plugin-tag(s) without myocamlbuild.ml - (patch by Jacques-Pascal Deplaix) + (patch by Jacques-Pascal Deplaix) - PR#6246: allow wilcard _ as for-loop index +- PR#6270: remove need for -I directives to ocamldebug in common case + (patch by Josh Watzman, review by Xavier Clerc and Alain Frisch) +- PR#6358: obey DESTDIR in install targets + (Gabriel Scherer) - ocamllex: user-definable refill action - (patch by Frédéric Bour, review by Gabriel Scherer and Luc Maranget) + (patch by Frédéric Bour, review by Gabriel Scherer and Luc Maranget) - shorten syntax for functor signatures: "functor (M1:S1) (M2:S2) .. -> .." (patches by Thomas Gazagnaire and Jeremy Yallop, review by Gabriel Scherer) -OCaml 4.01.1: -------------- - -Bug fixes: -- PR#4855: 'camlp4 -I +dir' accepted, dir is related to 'camlp4 -where' -- PR#5820: Fix camlp4 lexer roll back problem -- PR#6062: Fix a regression bug caused by commit 13047 -- PR#6165: Alterations to handling of \013 in source files breaking other tools -- PR#6173: Typing error message is worse that before -- PR#6174: OCaml compiler loops on an example using GADTs (non -rectypes) -- PR#6175: Fix open! -- PR#6183: enhanced documentation for 'Unix.shutdown_connection' -- PR#6216: inlining of GADT matches generates invalid assembly -- PR#6233: out-of-bounds exceptions lose their locations on ARM, PowerPC -- PR#6235: Issue with type information flowing through a variant pattern -- PR#6239: sometimes wrong stack alignment when raising exceptions - in -g mode with backtraces active -- PR#6240: Fail to expand module type abbreviation during substyping -- PR#6241: Assumed inequality between paths involving functor arguments -- PR#6243: Make "ocamlopt -g" more resistant to ill-formed locations -- PR#6267: more information printed by "bt" command of ocamldebug -- PR#6275: Soundness bug related to type constraints - OCaml 4.01.0: ------------- @@ -506,6 +508,8 @@ Bug fixes: (Jacques Garrigue, report by Leo P. White) - PR#6164: segmentation fault on Num.power_num of 0/1 (Fabrice Le Fessant, report by Johannes Kanig) +- PR#6210: Camlp4 location error + (Hongbo Zhang, report by Jun Furuse) Feature wishes: - PR#5181: Merge common floating point constants in ocamlopt @@ -699,6 +703,7 @@ Installation procedure: (-runtime-variant) to select the debug runtime. Bug Fixes: + - PR#1643: functions of the Lazy module whose named started with 'lazy_' have been deprecated, and new ones without the prefix added - PR#3571: in Bigarrays, call msync() before unmapping to commit changes @@ -294,29 +294,39 @@ base.opt: COMPLIBDIR=$(LIBDIR)/compiler-libs +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) +INSTALL_MANDIR=$(DESTDIR)$(MANDIR) + install: - if test -d $(BINDIR); then : ; else $(MKDIR) $(BINDIR); fi - if test -d $(LIBDIR); then : ; else $(MKDIR) $(LIBDIR); fi - if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(STUBLIBDIR); fi - if test -d $(COMPLIBDIR); then : ; else $(MKDIR) $(COMPLIBDIR); fi - if test -d $(MANDIR)/man$(MANEXT); then : ; \ - else $(MKDIR) $(MANDIR)/man$(MANEXT); fi - cp VERSION $(LIBDIR)/ - cd $(LIBDIR); rm -f dllbigarray.so dllnums.so dllthreads.so \ + if test -d $(INSTALL_BINDIR); then : ; \ + else $(MKDIR) $(INSTALL_BINDIR); fi + if test -d $(INSTALL_LIBDIR); then : ; \ + else $(MKDIR) $(INSTALL_LIBDIR); fi + if test -d $(INSTALL_STUBLIBDIR); then : ; \ + else $(MKDIR) $(INSTALL_STUBLIBDIR); fi + if test -d $(INSTALL_COMPLIBDIR); then : ; \ + else $(MKDIR) $(INSTALL_COMPLIBDIR); fi + if test -d $(INSTALL_MANDIR)/man$(MANEXT); then : ; \ + else $(MKDIR) $(INSTALL_MANDIR)/man$(MANEXT); fi + cp VERSION $(INSTALL_LIBDIR)/ + cd $(INSTALL_LIBDIR); rm -f dllbigarray.so dllnums.so dllthreads.so \ dllunix.so dllgraphics.so dllstr.so cd byterun; $(MAKE) install - cp ocamlc $(BINDIR)/ocamlc$(EXE) - cp ocaml $(BINDIR)/ocaml$(EXE) + cp ocamlc $(INSTALL_BINDIR)/ocamlc$(EXE) + cp ocaml $(INSTALL_BINDIR)/ocaml$(EXE) cd stdlib; $(MAKE) install - cp lex/ocamllex $(BINDIR)/ocamllex$(EXE) - cp yacc/ocamlyacc$(EXE) $(BINDIR)/ocamlyacc$(EXE) + cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex$(EXE) + cp yacc/ocamlyacc$(EXE) $(INSTALL_BINDIR)/ocamlyacc$(EXE) cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \ - toplevel/*.cmi $(COMPLIBDIR) + toplevel/*.cmi $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ - $(COMPLIBDIR) - cp expunge $(LIBDIR)/expunge$(EXE) - cp toplevel/topdirs.cmi $(LIBDIR) + $(INSTALL_COMPLIBDIR) + cp expunge $(INSTALL_LIBDIR)/expunge$(EXE) + cp toplevel/topdirs.cmi $(INSTALL_LIBDIR) cd tools; $(MAKE) install -cd man; $(MAKE) install for i in $(OTHERLIBRARIES); do \ @@ -327,16 +337,16 @@ install: else :; fi if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) install); \ else :; fi - cp config/Makefile $(LIBDIR)/Makefile.config + cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config if test -f ocamlopt; then $(MAKE) installopt; else :; fi # Installation of the native-code compiler installopt: cd asmrun; $(MAKE) install - cp ocamlopt $(BINDIR)/ocamlopt$(EXE) + cp ocamlopt $(INSTALL_BINDIR)/ocamlopt$(EXE) cd stdlib; $(MAKE) installopt - cp asmcomp/*.cmi $(COMPLIBDIR) - cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) + cp asmcomp/*.cmi $(INSTALL_COMPLIBDIR) + cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR) if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) installopt); \ else :; fi if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) installopt); \ @@ -347,16 +357,16 @@ installopt: cd tools; $(MAKE) installopt installoptopt: - cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) - cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) - cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) + cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE) + cp ocamlopt.opt $(INSTALL_BINDIR)/ocamlopt.opt$(EXE) + cp lex/ocamllex.opt $(INSTALL_BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \ - $(COMPLIBDIR) - cd $(COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \ + $(INSTALL_COMPLIBDIR) + cd $(INSTALL_COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \ ocamloptcomp.a clean:: partialclean @@ -378,9 +388,6 @@ partialclean:: ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh # The native-code compiler @@ -392,12 +399,9 @@ partialclean:: ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: - rm -f ocamlopt ocamlcompopt.sh + rm -f ocamlopt # The toplevel @@ -506,9 +510,6 @@ ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" - @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh partialclean:: rm -f ocamlc.opt @@ -525,9 +526,6 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(OPTSTART:.cmo=.cmx) - @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt.opt @@ -700,13 +698,15 @@ clean:: # Tools -ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi asmcomp/printclambda.cmo +ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmo cd tools; $(MAKE) all ocamltoolsopt: ocamlopt cd tools; $(MAKE) opt -ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi asmcomp/printclambda.cmx +ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmx cd tools; $(MAKE) opt.opt partialclean:: @@ -818,7 +818,7 @@ clean:: partialclean:: for d in utils parsing typing bytecomp asmcomp driver toplevel tools; \ - do rm -f $$d/*.cm[iox] $$d/*.annot $$d/*.[so] $$d/*~; done + do rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.[so] $$d/*~; done rm -f *~ depend: beforedepend @@ -834,7 +834,7 @@ distclean: boot/*.cm* boot/libcamlrun.a rm -f config/Makefile config/m.h config/s.h rm -f tools/*.bak tools/ocamlmklibconfig.ml - rm -f ocaml ocamlc ocamlcomp.sh + rm -f ocaml ocamlc rm -f testsuite/_log .PHONY: all backup bootstrap checkstack clean diff --git a/Makefile.nt b/Makefile.nt index 68a7e1d4d3..cfeaac4b52 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -117,12 +117,13 @@ all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ # Compile everything the first time world: coldstart all -# Complete bootstrapping cycle -bootstrap: +# Core bootstrapping cycle +coreboot: # Save the original bootstrap compiler $(MAKEREC) backup # Promote the new compiler but keep the old runtime -# This compiler runs on boot/ocamlrun and produces bytecode for byterun/ocamlrun +# This compiler runs on boot/ocamlrun and produces bytecode for +# byterun/ocamlrun $(MAKEREC) promote-cross # Rebuild ocamlc and ocamllex (run on byterun/ocamlrun) $(MAKEREC) partialclean @@ -131,12 +132,18 @@ bootstrap: $(MAKEREC) library-cross # Promote the new compiler and the new runtime $(MAKEREC) promote -# Rebuild everything, including ocaml and the tools +# Rebuild the core system $(MAKEREC) partialclean - $(MAKEREC) all + $(MAKEREC) core # Check if fixpoint reached $(MAKEREC) compare +# Do a complete bootstrapping cycle +bootstrap: + $(MAKEREC) coreboot + $(MAKEREC) all + $(MAKEREC) compare + LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader # Start up the system from the distribution compiler @@ -149,7 +156,7 @@ coldstart: cd stdlib ; cp $(LIBFILES) ../boot # Build the core system: the minimum needed to make depend and bootstrap -core : runtime ocamlc ocamllex ocamlyacc ocamltools library +core: runtime ocamlc ocamllex ocamlyacc ocamltools library # Save the current bootstrap compiler MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev @@ -201,11 +208,11 @@ opt-core: opt: $(MAKE) -f Makefile.nt opt-core - $(MAKE) -f Makefile.nt otherlibrariesopt + $(MAKE) -f Makefile.nt otherlibrariesopt ocamltoolsopt # Native-code versions of the tools opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \ - ocamltoolsopt.opt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT) + ocamltoolsopt ocamltoolsopt.opt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT) # Complete build using fast compilers world.opt: coldstart opt.opt @@ -214,63 +221,71 @@ world.opt: coldstart opt.opt COMPLIBDIR=$(LIBDIR)/compiler-libs +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) +INSTALL_MANDIR=$(DESTDIR)$(MANDIR) + install: installbyt installopt installbyt: - mkdir -p $(BINDIR) - mkdir -p $(LIBDIR) - mkdir -p $(COMPLIBDIR) + mkdir -p $(INSTALL_BINDIR) + mkdir -p $(INSTALL_LIBDIR) + mkdir -p $(INSTALL_STUBLIBDIR) + mkdir -p $(INSTALL_COMPLIBDIR) + cp VERSION $(INSTALL_LIBDIR)/ cd byterun ; $(MAKEREC) install - cp ocamlc $(BINDIR)/ocamlc.exe - cp ocaml $(BINDIR)/ocaml.exe + cp ocamlc $(INSTALL_BINDIR)/ocamlc.exe + cp ocaml $(INSTALL_BINDIR)/ocaml.exe cd stdlib ; $(MAKEREC) install - cp lex/ocamllex $(BINDIR)/ocamllex.exe - cp yacc/ocamlyacc.exe $(BINDIR)/ocamlyacc.exe + cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex.exe + cp yacc/ocamlyacc.exe $(INSTALL_BINDIR)/ocamlyacc.exe cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \ - toplevel/*.cmi $(COMPLIBDIR) + toplevel/*.cmi $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ - $(COMPLIBDIR) - cp expunge $(LIBDIR)/expunge.exe - cp toplevel/topdirs.cmi $(LIBDIR) + $(INSTALL_COMPLIBDIR) + cp expunge $(INSTALL_LIBDIR)/expunge.exe + cp toplevel/topdirs.cmi $(INSTALL_LIBDIR) cd tools ; $(MAKEREC) install + for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) install); \ else :; fi - mkdir -p $(STUBLIBDIR) - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done if test -n "$(WITH_DEBUGGER)"; then (cd debugger; $(MAKEREC) install); \ else :; fi if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) install); \ else :; fi - cp config/Makefile $(LIBDIR)/Makefile.config - cp README $(DISTRIB)/Readme.general.txt - cp README.win32 $(DISTRIB)/Readme.windows.txt - cp LICENSE $(DISTRIB)/License.txt - cp Changes $(DISTRIB)/Changes.txt + cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config + cp README $(INSTALL_DISTRIB)/Readme.general.txt + cp README.win32 $(INSTALL_DISTRIB)/Readme.windows.txt + cp LICENSE $(INSTALL_DISTRIB)/License.txt + cp Changes $(INSTALL_DISTRIB)/Changes.txt # Installation of the native-code compiler installopt: cd asmrun ; $(MAKEREC) install - cp ocamlopt $(BINDIR)/ocamlopt.exe + cp ocamlopt $(INSTALL_BINDIR)/ocamlopt.exe cd stdlib ; $(MAKEREC) installopt - cp asmcomp/*.cmi driver/*.cmi $(COMPLIBDIR) - cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) + cp asmcomp/*.cmi $(INSTALL_COMPLIBDIR) + cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR) if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) installopt); fi if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) installopt); \ else :; fi for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i installopt; done if test -f ocamlopt.opt ; then $(MAKEREC) installoptopt; fi + cd tools; $(MAKE) installopt installoptopt: - cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) - cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) - cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) + cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE) + cp ocamlopt.opt $(INSTALL_BINDIR)/ocamlopt.opt$(EXE) + cp lex/ocamllex.opt $(INSTALL_BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.$(O)) \ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.$(O)) \ - $(COMPLIBDIR) + $(INSTALL_COMPLIBDIR) clean:: partialclean @@ -291,12 +306,9 @@ partialclean:: ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc compilerlibs/ocamlcommon.cma \ compilerlibs/ocamlbytecomp.cma $(BYTESTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh partialclean:: - rm -f ocamlc ocamlcomp.sh + rm -f ocamlc # The native-code compiler @@ -308,12 +320,9 @@ partialclean:: ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: - rm -f ocamlopt ocamlcompopt.sh + rm -f ocamlopt # The toplevel @@ -426,9 +435,6 @@ ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" - @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh partialclean:: rm -f ocamlc.opt @@ -445,9 +451,6 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(OPTSTART:.cmo=.cmx) - @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt.opt @@ -614,10 +617,17 @@ clean:: # Tools -ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi asmcomp/printclambda.cmo +ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmo cd tools ; $(MAKEREC) all -ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi asmcomp/printclambda.cmx + +ocamltoolsopt: + cd tools ; $(MAKEREC) opt + +ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmx cd tools ; $(MAKEREC) opt.opt + partialclean:: cd tools ; $(MAKEREC) clean alldepend:: @@ -714,8 +724,8 @@ distclean: .PHONY: coreboot defaultentry depend distclean install installopt .PHONY: library library-cross libraryopt ocamlbuild-mixed-boot .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc -.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt -.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries +.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt +.PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries .PHONY: otherlibrariesopt promote promote-cross .PHONY: restore runtime runtimeopt makeruntimeopt world world.opt @@ -1,4 +1,4 @@ -4.02.0+dev3-2013-12-19 +4.02.0+dev4-2014-04-03 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index 274e6ffcaf..4a3e3cd7b4 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -104,7 +104,7 @@ let emit_stack r = (* Output an addressing mode *) let emit_symbol_offset s ofs = - emit_symbol s; + emit_symbol s; if ofs > 0 then `+{emit_int ofs}` else if ofs < 0 then `-{emit_int (-ofs)}` else () @@ -578,7 +578,7 @@ let emit_instr i = for j = 0 to Array.length jumptbl - 1 do ` b {emit_label jumptbl.(j)}\n` done -(* Alternative: +(* Alternative: let lbltbl = new_label() in ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; ` ldr {emit_wreg reg_tmp2}, [{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2]\n`; @@ -652,7 +652,7 @@ let fundecl fundecl = cfi_startproc(); if !Clflags.gprofile then emit_profile(); let n = frame_size() in - if n > 0 then + if n > 0 then emit_stack_adjustment (-n); if !contains_calls then ` str x30, [sp, #{emit_int (n-8)}]\n`; diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml index 36b4018944..e7ded8fb43 100644 --- a/asmcomp/arm64/selection.ml +++ b/asmcomp/arm64/selection.ml @@ -37,7 +37,7 @@ let is_offset chunk n = / \ / \ / \ \ / \ / \ / -0--> [1] --1--> [2] --0--> [3] - / + / [0] \ -1--> [4] --0--> [5] --1--> [6] @@ -61,7 +61,7 @@ let auto_table = [| (* accepting?, next on 0, next on 1 *) let rec run_automata nbits state input = let (acc, next0, next1) = auto_table.(state) in if nbits <= 0 - then acc + then acc else run_automata (nbits - 1) (if input land 1 = 0 then next0 else next1) (input asr 1) @@ -71,7 +71,7 @@ let rec run_automata nbits state input = pattern of this kind. *) let is_logical_immediate n = - n <> 0 && n <> -1 && run_automata 64 0 n + n <> 0 && n <> -1 && run_automata 64 0 n let is_intconst = function Cconst_int _ -> true diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index c4baf6cf9c..3586296e4f 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -43,7 +43,7 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch - | Ustringswitch of ulambda * (string * ulambda) list * ulambda + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 1853933c91..e751326fe4 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -43,7 +43,7 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch - | Ustringswitch of ulambda * (string * ulambda) list * ulambda + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 78357d3b11..eff35ce4f2 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -19,6 +19,14 @@ open Lambda open Switch open Clambda +module Storer = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + (* Auxiliaries for compiling functions *) let rec split_list n l = @@ -63,7 +71,7 @@ let occurs_var var u = | Ustringswitch(arg,sw,d) -> occurs arg || List.exists (fun (_,e) -> occurs e) sw || - occurs d + (match d with None -> false | Some d -> occurs d) | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr @@ -198,7 +206,7 @@ let lambda_smaller lam threshold = size := !size+2 ; lambda_size lam) sw ; - lambda_size d + Misc.may lambda_size d | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler @@ -432,7 +440,7 @@ let rec substitute sb ulam = Ustringswitch (substitute sb arg, List.map (fun (s,act) -> s,substitute sb act) sw, - substitute sb d) + Misc.may_map (substitute sb) d) | Ustaticfail (nfail, args) -> Ustaticfail (nfail, List.map (substitute sb) args) | Ucatch(nfail, ids, u1, u2) -> @@ -779,27 +787,48 @@ let rec close fenv cenv = function | Lprim(p, args) -> simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none | Lswitch(arg, sw) -> + let fn fail = + let (uarg, _) = close fenv cenv arg in + let const_index, const_actions, fconst = + close_switch arg fenv cenv sw.sw_consts sw.sw_numconsts fail + and block_index, block_actions, fblock = + close_switch arg fenv cenv sw.sw_blocks sw.sw_numblocks fail in + let ulam = + Uswitch + (uarg, + {us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions}) in + (fconst (fblock ulam),Value_unknown) in (* NB: failaction might get copied, thus it should be some Lstaticraise *) - let (uarg, _) = close fenv cenv arg in - let const_index, const_actions = - close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction - and block_index, block_actions = - close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in - (Uswitch(uarg, - {us_index_consts = const_index; - us_actions_consts = const_actions; - us_index_blocks = block_index; - us_actions_blocks = block_actions}), - Value_unknown) + let fail = sw.sw_failaction in + begin match fail with + | None|Some (Lstaticraise (_,_)) -> fn fail + | Some lamfail -> + if + (sw.sw_numconsts - List.length sw.sw_consts) + + (sw.sw_numblocks - List.length sw.sw_blocks) > 1 + then + let i = next_raise_count () in + let ubody,_ = fn (Some (Lstaticraise (i,[]))) + and uhandler,_ = close fenv cenv lamfail in + Ucatch (i,[],ubody,uhandler),Value_unknown + else fn fail + end | Lstringswitch(arg,sw,d) -> let uarg,_ = close fenv cenv arg in - let usw = + let usw = List.map (fun (s,act) -> let uact,_ = close fenv cenv act in s,uact) sw in - let ud,_ = close fenv cenv d in + let ud = + Misc.may_map + (fun d -> + let ud,_ = close fenv cenv d in + ud) d in Ustringswitch (uarg,usw,ud),Value_unknown | Lstaticraise (i, args) -> (Ustaticfail (i, close_list fenv cenv args), Value_unknown) @@ -996,14 +1025,15 @@ and close_one_function fenv cenv id funct = (* Close a switch *) -and close_switch fenv cenv cases num_keys default = +and close_switch arg fenv cenv cases num_keys default = + let ncases = List.length cases in let index = Array.create num_keys 0 - and store = mk_store Lambda.same in + and store = Storer.mk_store () in (* First default case *) begin match default with - | Some def when List.length cases < num_keys -> - ignore (store.act_store def) + | Some def when ncases < num_keys -> + assert (store.act_store def = 0) | _ -> () end ; (* Then all other cases *) @@ -1011,16 +1041,37 @@ and close_switch fenv cenv cases num_keys default = (fun (key,lam) -> index.(key) <- store.act_store lam) cases ; - (* Compile action *) + + (* Explicit sharing with catch/exit, as switcher compilation may + later unshare *) + let acts = store.act_get_shared () in + let hs = ref (fun e -> e) in + + (* Compile actions *) let actions = Array.map - (fun lam -> - let ulam,_ = close fenv cenv lam in - ulam) - (store.act_get ()) in + (function + | Single lam|Shared (Lstaticraise (_,[]) as lam) -> + let ulam,_ = close fenv cenv lam in + ulam + | Shared lam -> + let ulam,_ = close fenv cenv lam in + let i = next_raise_count () in +(* + let string_of_lambda e = + Printlambda.lambda Format.str_formatter e ; + Format.flush_str_formatter () in + Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i + (string_of_lambda arg) + (string_of_lambda lam) ; +*) + let ohs = !hs in + hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ; + Ustaticfail (i,[])) + acts in match actions with - | [| |] -> [| |], [| |] (* May happen when default is None *) - | _ -> index, actions + | [| |] -> [| |], [| |], !hs (* May happen when default is None *) + | _ -> index, actions, !hs (* Collect exported symbols for structured constants *) @@ -1065,7 +1116,7 @@ let collect_exported_structured_constants a = | Ustringswitch (u,sw,d) -> ulam u ; List.iter (fun (_,act) -> ulam act) sw ; - ulam d + Misc.may ulam d | Ustaticfail (_, ul) -> List.iter ulam ul | Ucatch (_, _, u1, u2) | Utrywith (u1, _, u2) diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 0f9252361f..10c4303f82 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -993,8 +993,22 @@ let unaligned_set_64 ptr idx newval = Cop(Cstore Byte_unsigned, [add_int (add_int ptr idx) (Cconst_int 7); b8])))) +let max_or_zero a = + bind "size" a (fun a -> + (* equivalent to + Cifthenelse(Cop(Ccmpi Cle, [a; Cconst_int 0]), Cconst_int 0, a) + + if a is positive, sign is 0 hence sign_negation is full of 1 + so sign_negation&a = a + if a is negative, sign is full of 1 hence sign_negation is 0 + so sign_negation&a = 0 *) + let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1)]) in + let sign_negation = Cop(Cxor, [sign; Cconst_int (-1)]) in + Cop(Cand, [sign_negation; a])) + let check_bound unsafe dbg a1 a2 k = - if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) + if unsafe then k + else Csequence(make_checkbound dbg [max_or_zero a1;a2], k) (* Simplification of some primitives into C calls *) @@ -1057,28 +1071,9 @@ let simplif_primitive p = (* Build switchers both for constants and blocks *) -(* constants first *) - let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) -let make_switch_gen arg cases acts = - let lcases = Array.length cases in - let new_cases = Array.create lcases 0 in - let store = Switch.mk_store (=) in - - for i = 0 to Array.length cases-1 do - let act = cases.(i) in - let new_act = store.Switch.act_store act in - new_cases.(i) <- new_act - done ; - Cswitch - (arg, new_cases, - Array.map - (fun n -> acts.(n)) - (store.Switch.act_get ())) - - -(* Then for blocks *) +(* Build an actual switch (ie jump table) *) module SArgBlocks = struct @@ -1094,17 +1089,47 @@ struct type act = expression let default = Cexit (0,[]) + let make_const i = Cconst_int i let make_prim p args = Cop (p,args) let make_offset arg n = add_const arg n let make_isout h arg = Cop (Ccmpa Clt, [h ; arg]) let make_isin h arg = Cop (Ccmpa Cge, [h ; arg]) let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) - let make_switch arg cases actions = - make_switch_gen arg cases actions + let make_switch arg cases actions = Cswitch (arg,cases,actions) let bind arg body = bind "switcher" arg body + let make_catch handler = match handler with + | Cexit (i,[]) -> i,fun e -> e + | _ -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE CMM: %i\n" i ; + Printcmm.expression Format.str_formatter handler ; + Printf.eprintf "%s\n" (Format.flush_str_formatter ()) ; +*) + i, + (fun body -> match body with + | Cexit (j,_) -> + if i=j then handler + else body + | _ -> Ccatch (i,[],body,handler)) + + let make_exit i = Cexit (i,[]) + end +(* cmm store, as sharing as normally been detected in previous + phases, we only share exits *) +module StoreExp = + Switch.Store + (struct + type t = expression + type key = int + let make_key = function + | Cexit (i,[]) -> Some i + | _ -> None + end) + module SwitcherBlocks = Switch.Make(SArgBlocks) (* Int switcher, arg in [low..high], @@ -1112,35 +1137,48 @@ module SwitcherBlocks = Switch.Make(SArgBlocks) let transl_int_switch arg low high cases default = match cases with | [] -> assert false -| (k0,_)::_ -> - let nacts = List.length cases + 1 in - let actions = Array.create nacts default in - let rec set_acts idx = function - | [] -> assert false - | [i,act] -> - actions.(idx) <- act ; - if i = high then [(i,i,idx)] - else [(i,i,idx); (i+1,max_int,0)] - | (i,act)::((j,_)::_ as rem) -> - actions.(idx) <- act ; - let inters = set_acts (idx+1) rem in - (i,i,idx):: - begin - if j = i+1 then inters - else (i+1,j-1,0)::inters - end in - let inters = set_acts 1 cases in - let inters = - if k0 = low then inters else (low,k0-1,0)::inters in - bind "switcher" arg - (fun a -> - SwitcherBlocks.zyva - (low,high) - (fun i -> Cconst_int i) - a - (Array.of_list inters) actions) - - +| _::_ -> + let store = StoreExp.mk_store () in + assert (store.Switch.act_store default = 0) ; + let cases = + List.map + (fun (i,act) -> i,store.Switch.act_store act) + cases in + let rec inters plow phigh pact = function + | [] -> + if phigh = high then [plow,phigh,pact] + else [(plow,phigh,pact); (phigh+1,high,0) ] + | (i,act)::rem -> + if i = phigh+1 then + if pact = act then + inters plow i pact rem + else + (plow,phigh,pact)::inters i i act rem + else (* insert default *) + if pact = 0 then + if act = 0 then + inters plow i 0 rem + else + (plow,i-1,pact):: + inters i i act rem + else (* pact <> 0 *) + (plow,phigh,pact):: + begin + if act = 0 then inters (phigh+1) i 0 rem + else (phigh+1,i-1,0)::inters i i act rem + end in + let inters = match cases with + | [] -> assert false + | (k0,act0)::rem -> + if k0 = low then inters k0 k0 act0 rem + else inters low (k0-1) 0 cases in + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (low,high) + a + (Array.of_list inters) store) + (* Auxiliary functions for optimizing "let" of boxed numbers (floats and boxed integers *) @@ -1242,7 +1280,7 @@ let strmatch_compile = let transl_switch = transl_int_switch end) in S.compile - + let rec transl = function Uvar id -> Cvar id @@ -1419,7 +1457,7 @@ let rec transl = function | Ustringswitch(arg,sw,d) -> bind "switch" (transl arg) (fun arg -> - strmatch_compile arg (transl d) + strmatch_compile arg (Misc.may_map transl d) (List.map (fun (s,act) -> s,transl act) sw)) | Ustaticfail (nfail, args) -> Cexit (nfail, List.map transl args) @@ -1977,7 +2015,7 @@ and transl_unbox_int bi = function Cconst_int i | exp -> unbox_int bi (transl exp) -and transl_unbox_let box_fn unbox_fn transl_unbox_fn box_chunk box_offset +and transl_unbox_let box_fn unbox_fn transl_unbox_fn box_chunk box_offset id exp body = let unboxed_id = Ident.create (Ident.name id) in let trbody1 = transl body in @@ -2069,9 +2107,13 @@ and transl_switch arg index cases = match Array.length cases with | 0 -> fatal_error "Cmmgen.transl_switch" | 1 -> transl cases.(0) | _ -> + let cases = Array.map transl cases in + let store = StoreExp.mk_store () in + let index = + Array.map + (fun j -> store.Switch.act_store cases.(j)) + index in let n_index = Array.length index in - let actions = Array.map transl cases in - let inters = ref [] and this_high = ref (n_index-1) and this_low = ref (n_index-1) @@ -2088,13 +2130,15 @@ and transl_switch arg index cases = match Array.length cases with end done ; inters := (0, !this_high, !this_act) :: !inters ; - bind "switcher" arg - (fun a -> - SwitcherBlocks.zyva - (0,n_index-1) - (fun i -> Cconst_int i) - a - (Array.of_list !inters) actions) + match !inters with + | [_] -> cases.(0) + | inters -> + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (0,n_index-1) + a + (Array.of_list inters) store) and transl_letrec bindings cont = let bsz = @@ -2187,7 +2231,8 @@ let rec emit_structured_constant symb cst cont = and emit_constant cst cont = match cst with | Uconst_int n | Uconst_ptr n -> - Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) :: cont + Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + :: cont | Uconst_ref (label, _) -> Csymbol_address label :: cont diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 80be94e9f7..49a846667d 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -108,7 +108,7 @@ let make_symbol ?(unitname = current_unit.ui_symbol) idopt = let symbol_in_current_unit name = let prefix = "caml" ^ current_unit.ui_symbol in - name = prefix || + name = prefix || (let lp = String.length prefix in String.length name >= 2 + lp && String.sub name 0 lp = prefix diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 9c2eb62975..b705f4496d 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -59,7 +59,8 @@ val new_structured_constant: Clambda.ustructured_constant -> shared:bool -> (* can be shared with another structually equal constant *) string -val structured_constants: unit -> (string * bool * Clambda.ustructured_constant) list +val structured_constants: + unit -> (string * bool * Clambda.ustructured_constant) list val add_exported_constant: string -> unit type structured_constants diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml index 3d4c32c0ae..f4e3b4d93f 100644 --- a/asmcomp/printclambda.ml +++ b/asmcomp/printclambda.ml @@ -51,7 +51,7 @@ let rec lam ppf = function let idents ppf = List.iter (fprintf ppf "@ %a" Ident.print)in let one_fun ppf f = - fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])" + fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])" f.label f.arity idents f.params lam f.body in let funs ppf = List.iter (fprintf ppf "@ %a" one_fun) in @@ -83,22 +83,20 @@ let rec lam ppf = function List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs | Uswitch(larg, sw) -> - let switch ppf sw = - let spc = ref false in - for i = 0 to Array.length sw.us_index_consts - 1 do - let n = sw.us_index_consts.(i) in - let l = sw.us_actions_consts.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<hv 1>case int %i:@ %a@]" i lam l; - done; - for i = 0 to Array.length sw.us_index_blocks - 1 do - let n = sw.us_index_blocks.(i) in - let l = sw.us_actions_blocks.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<hv 1>case tag %i:@ %a@]" i lam l; + let print_case tag index i ppf = + for j = 0 to Array.length index - 1 do + if index.(j) = i then fprintf ppf "case %s %i:" tag j + done in + let print_cases tag index cases ppf = + for i = 0 to Array.length cases - 1 do + fprintf ppf "@ @[<2>%t@ %a@]" + (print_case tag index i) sequence cases.(i) done in + let switch ppf sw = + print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ; + print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in fprintf ppf - "@[<1>(switch %a@ @[<v 0>%a@])@]" + "@[<v 0>@[<2>(switch@ %a@ @]%a)@]" lam larg switch sw | Ustringswitch(larg,sw,d) -> let switch ppf sw = @@ -109,8 +107,12 @@ let rec lam ppf = function fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" (String.escaped s) lam l) sw ; - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<hv 1>default:@ %a@]" lam d in + begin match d with + | Some d -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<hv 1>default:@ %a@]" lam d + | None -> () + end in fprintf ppf "@[<1>(switch %a@ @[<v 0>%a@])@]" lam larg switch sw | Ustaticfail (i, ls) -> @@ -186,4 +188,3 @@ let rec approx ppf = function fprintf ppf "@[const(%a)@]" uconstant c | Value_global_field (s, i) -> fprintf ppf "@[global(%s,%i)@]" s i - diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml index 760540d8a3..d63e92bf03 100644 --- a/asmcomp/strmatch.ml +++ b/asmcomp/strmatch.ml @@ -45,7 +45,7 @@ module Make(I:I) = struct if Arch.big_endian then ds else List.rev ds in String.concat "" ds - let do_pp_cases chan cases = + let do_pp_cases chan cases = List.iter (fun (ps,_) -> Printf.fprintf chan " [%s]\n" @@ -168,7 +168,7 @@ module Make(I:I) = struct (fun set (ps,_) -> IntSet.add (List.length ps) set) IntSet.empty cases in IntSet.cardinal set - + let best_col = let rec do_rec kbest best k = function | [] -> kbest @@ -225,7 +225,6 @@ module Make(I:I) = struct try OMap.find key env with Not_found -> assert false - let divide cases = let env = List.fold_left @@ -290,7 +289,6 @@ module Make(I:I) = struct let lt,midkey,ge = split_env len env in mk_lt id midkey (comp_rec lt) (comp_rec ge) in mk_let_cell id str idx (comp_rec env) - (* Recursive 'list of cells' compile function: @@ -319,7 +317,7 @@ module Make(I:I) = struct (* Group by size *) - + module DivideInt = Divide(IntArg) @@ -353,8 +351,8 @@ module Make(I:I) = struct (* Compilation entry point: we choose to switch either on size or on first cell, using the - 'least discriminant' heuristics. - *) + 'least discriminant' heuristics. + *) let top_compile str default cases = let a_len = count_arities_length cases and a_fst = count_arities_first cases in @@ -377,6 +375,11 @@ module Make(I:I) = struct Ccatch (e,[],k (Cexit (e,[])),arg) let compile str default cases = +(* We do not attempt to really optimise default=None *) + let cases,default = match cases,default with + | (_,e)::cases,None + | cases,Some e -> cases,e + | [],None -> assert false in let cases = List.rev_map (fun (s,act) -> pat_of_string s,act) diff --git a/asmcomp/strmatch.mli b/asmcomp/strmatch.mli index 9be2b69451..143dae5cb6 100644 --- a/asmcomp/strmatch.mli +++ b/asmcomp/strmatch.mli @@ -23,6 +23,6 @@ end module Make(I:I) : sig (* Compile stringswitch (arg,cases,d) Note: cases should not contain string duplicates *) - val compile : Cmm.expression (* arg *) -> Cmm.expression (* d *) -> + val compile : Cmm.expression (* arg *) -> Cmm.expression option (* d *) -> (string * Cmm.expression) list (* cases *)-> Cmm.expression end diff --git a/asmrun/Makefile b/asmrun/Makefile index fa8aa6a72c..6c6dd98a8e 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -60,26 +60,29 @@ libasmrunp.a: $(POBJS) ar rc libasmrunp.a $(POBJS) $(RANLIB) libasmrunp.a +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install: install-default install-$(RUNTIMED) install-$(PROFILING) install-default: - cp libasmrun.a $(LIBDIR)/libasmrun.a - cd $(LIBDIR); $(RANLIB) libasmrun.a + cp libasmrun.a $(INSTALL_LIBDIR)/libasmrun.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrun.a install-noruntimed: .PHONY: install-noruntimed install-runtimed: - cp libasmrund.a $(LIBDIR)/libasmrund.a - cd $(LIBDIR); $(RANLIB) libasmrund.a + cp libasmrund.a $(INSTALL_LIBDIR)/libasmrund.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrund.a .PHONY: install-runtimed install-noprof: - rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a + rm -f $(INSTALL_LIBDIR)/libasmrunp.a + ln -s libasmrun.a $(INSTALL_LIBDIR)/libasmrunp.a install-prof: - cp libasmrunp.a $(LIBDIR)/libasmrunp.a - cd $(LIBDIR); $(RANLIB) libasmrunp.a + cp libasmrunp.a $(INSTALL_LIBDIR)/libasmrunp.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a power-bsd_elf.S: power-elf.S cp power-elf.S power-bsd_elf.S diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 876fe60244..77c2002d4f 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -56,8 +56,10 @@ i386.o: i386.S amd64.o: amd64.S $(ASPP) -DSYS_$(SYSTEM) amd64.S +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install: - cp libasmrun.$(A) $(LIBDIR) + cp libasmrun.$(A) $(INSTALL_LIBDIR) $(LINKEDFILES): %.c: ../byterun/%.c cp ../byterun/$*.c $*.c diff --git a/asmrun/arm64.S b/asmrun/arm64.S index de670e6605..2c16a0eadb 100644 --- a/asmrun/arm64.S +++ b/asmrun/arm64.S @@ -44,30 +44,30 @@ #if defined(__PIC__) #define ADDRGLOBAL(reg,symb) \ - adrp TMP2, :got:symb; \ - ldr reg, [TMP2, #:got_lo12:symb] + adrp TMP2, :got:symb; \ + ldr reg, [TMP2, #:got_lo12:symb] #define LOADGLOBAL(reg,symb) \ - ADDRGLOBAL(TMP2,symb); \ - ldr reg, [TMP2] + ADDRGLOBAL(TMP2,symb); \ + ldr reg, [TMP2] #define STOREGLOBAL(reg,symb) \ - ADDRGLOBAL(TMP2,symb); \ - str reg, [TMP2] + ADDRGLOBAL(TMP2,symb); \ + str reg, [TMP2] #else #define ADDRGLOBAL(reg,symb) \ - adrp reg, symb; \ - add reg, reg, #:lo12:symb + adrp reg, symb; \ + add reg, reg, #:lo12:symb #define LOADGLOBAL(reg,symb) \ - adrp TMP2, symb; \ - ldr reg, [TMP2, #:lo12:symb] + adrp TMP2, symb; \ + ldr reg, [TMP2, #:lo12:symb] #define STOREGLOBAL(reg,symb) \ - adrp TMP2, symb; \ - str reg, [TMP2, #:lo12:symb] + adrp TMP2, symb; \ + str reg, [TMP2, #:lo12:symb] #endif @@ -82,11 +82,11 @@ caml_call_gc: CFI_STARTPROC PROFILE /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) + STOREGLOBAL(x30, caml_last_return_address) .Lcaml_call_gc: /* Record lowest stack address */ - mov TMP, sp - STOREGLOBAL(TMP, caml_bottom_of_stack) + mov TMP, sp + STOREGLOBAL(TMP, caml_bottom_of_stack) /* Set up stack space, saving return address and frame pointer */ /* (2 regs RA/GP, 24 allocatable int regs, 24 caller-save float regs) * 8 */ stp x29, x30, [sp, -400]! @@ -94,7 +94,7 @@ caml_call_gc: add x29, sp, #0 /* Save allocatable integer registers on the stack, in the order given in proc.ml */ - stp x0, x1, [sp, 16] + stp x0, x1, [sp, 16] stp x2, x3, [sp, 32] stp x4, x5, [sp, 48] stp x6, x7, [sp, 64] @@ -121,16 +121,16 @@ caml_call_gc: stp d28, d29, [sp, 368] stp d30, d31, [sp, 384] /* Store pointer to saved integer registers in caml_gc_regs */ - add TMP, sp, #16 - STOREGLOBAL(TMP, caml_gc_regs) + add TMP, sp, #16 + STOREGLOBAL(TMP, caml_gc_regs) /* Save current allocation pointer for debugging purposes */ - STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) /* Save trap pointer in case an exception is raised during GC */ - STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) /* Call the garbage collector */ bl caml_garbage_collection /* Restore registers */ - ldp x0, x1, [sp, 16] + ldp x0, x1, [sp, 16] ldp x2, x3, [sp, 32] ldp x4, x5, [sp, 48] ldp x6, x7, [sp, 64] @@ -155,10 +155,10 @@ caml_call_gc: ldp d28, d29, [sp, 368] ldp d30, d31, [sp, 384] /* Reload new allocation pointer and allocation limit */ - LOADGLOBAL(ALLOC_PTR, caml_young_ptr) - LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) /* Free stack space and return to caller */ - ldp x29, x30, [sp], 400 + ldp x29, x30, [sp], 400 ret CFI_ENDPROC .type caml_call_gc, %function @@ -177,11 +177,11 @@ caml_alloc1: CFI_ADJUST(16) add x29, sp, #0 /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) + STOREGLOBAL(x30, caml_last_return_address) /* Call GC */ bl .Lcaml_call_gc /* Restore return address */ - ldp x29, x30, [sp], 16 + ldp x29, x30, [sp], 16 CFI_ADJUST(-16) /* Try again */ b 1b @@ -202,18 +202,18 @@ caml_alloc2: CFI_ADJUST(16) add x29, sp, #0 /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) + STOREGLOBAL(x30, caml_last_return_address) /* Call GC */ bl .Lcaml_call_gc /* Restore return address */ - ldp x29, x30, [sp], 16 + ldp x29, x30, [sp], 16 CFI_ADJUST(-16) /* Try again */ b 1b CFI_ENDPROC .type caml_alloc2, %function .size caml_alloc2, .-caml_alloc2 - + .align 2 .globl caml_alloc3 caml_alloc3: @@ -227,18 +227,18 @@ caml_alloc3: CFI_ADJUST(16) add x29, sp, #0 /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) + STOREGLOBAL(x30, caml_last_return_address) /* Call GC */ bl .Lcaml_call_gc /* Restore return address */ - ldp x29, x30, [sp], 16 + ldp x29, x30, [sp], 16 CFI_ADJUST(-16) /* Try again */ b 1b CFI_ENDPROC .type caml_alloc2, %function .size caml_alloc2, .-caml_alloc2 - + .align 2 .globl caml_allocN caml_allocN: @@ -252,11 +252,11 @@ caml_allocN: CFI_ADJUST(16) add x29, sp, #0 /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) + STOREGLOBAL(x30, caml_last_return_address) /* Call GC. This preserves ARG */ bl .Lcaml_call_gc /* Restore return address */ - ldp x29, x30, [sp], 16 + ldp x29, x30, [sp], 16 CFI_ADJUST(-16) /* Try again */ b 1b @@ -279,12 +279,12 @@ caml_c_call: add TMP, sp, #0 STOREGLOBAL(TMP, caml_bottom_of_stack) /* Make the exception handler alloc ptr available to the C code */ - STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) STOREGLOBAL(TRAP_PTR, caml_exception_pointer) /* Call the function */ blr ARG /* Reload alloc ptr and alloc limit */ - LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) /* Return */ ret x19 @@ -299,7 +299,7 @@ caml_c_call: caml_start_program: CFI_STARTPROC PROFILE - ADDRGLOBAL(ARG, caml_program) + ADDRGLOBAL(ARG, caml_program) /* Code shared with caml_callback* */ /* Address of OCaml code to call is in ARG */ @@ -307,62 +307,62 @@ caml_start_program: .Ljump_to_caml: /* Set up stack frame and save callee-save registers */ - stp x29, x30, [sp, -160]! + stp x29, x30, [sp, -160]! CFI_ADJUST(160) - add x29, sp, #0 + add x29, sp, #0 stp x19, x20, [sp, 16] stp x21, x22, [sp, 32] stp x23, x24, [sp, 48] stp x25, x26, [sp, 64] stp x27, x28, [sp, 80] - stp d8, d9, [sp, 96] + stp d8, d9, [sp, 96] stp d10, d11, [sp, 112] stp d12, d13, [sp, 128] stp d14, d15, [sp, 144] /* Setup a callback link on the stack */ - LOADGLOBAL(x8, caml_bottom_of_stack) + LOADGLOBAL(x8, caml_bottom_of_stack) LOADGLOBAL(x9, caml_last_return_address) LOADGLOBAL(x10, caml_gc_regs) stp x8, x9, [sp, -32]! /* 16-byte alignment */ CFI_ADJUST(32) str x10, [sp, 16] /* Setup a trap frame to catch exceptions escaping the OCaml code */ - LOADGLOBAL(x8, caml_exception_pointer) + LOADGLOBAL(x8, caml_exception_pointer) adr x9, .Ltrap_handler stp x8, x9, [sp, -16]! CFI_ADJUST(16) add TRAP_PTR, sp, #0 /* Reload allocation pointers */ - LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) /* Call the OCaml code */ blr ARG .Lcaml_retaddr: /* Pop the trap frame, restoring caml_exception_pointer */ - ldr x8, [sp], 16 + ldr x8, [sp], 16 CFI_ADJUST(-16) STOREGLOBAL(x8, caml_exception_pointer) /* Pop the callback link, restoring the global variables */ .Lreturn_result: - ldr x10, [sp, 16] + ldr x10, [sp, 16] ldp x8, x9, [sp], 32 CFI_ADJUST(-32) - STOREGLOBAL(x8, caml_bottom_of_stack) + STOREGLOBAL(x8, caml_bottom_of_stack) STOREGLOBAL(x9, caml_last_return_address) STOREGLOBAL(x10, caml_gc_regs) /* Update allocation pointer */ - STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) /* Reload callee-save registers and return address */ ldp x19, x20, [sp, 16] ldp x21, x22, [sp, 32] ldp x23, x24, [sp, 48] ldp x25, x26, [sp, 64] ldp x27, x28, [sp, 80] - ldp d8, d9, [sp, 96] + ldp d8, d9, [sp, 96] ldp d10, d11, [sp, 112] ldp d12, d13, [sp, 128] ldp d14, d15, [sp, 144] - ldp x29, x30, [sp], 160 + ldp x29, x30, [sp], 160 CFI_ADJUST(-160) /* Return to C caller */ ret @@ -400,7 +400,7 @@ caml_raise_exn: 1: /* Cut stack at current trap handler */ mov sp, TRAP_PTR /* Pop previous handler and jump to it */ - ldr TMP, [sp, 8] + ldr TMP, [sp, 8] ldr TRAP_PTR, [sp], 16 br TMP 2: /* Preserve exception bucket in callee-save register x19 */ @@ -413,7 +413,7 @@ caml_raise_exn: bl caml_stash_backtrace /* Restore exception bucket and raise */ mov x0, x19 - b 1b + b 1b CFI_ENDPROC .type caml_raise_exn, %function .size caml_raise_exn, .-caml_raise_exn @@ -430,12 +430,12 @@ caml_raise_exception: LOADGLOBAL(ALLOC_PTR, caml_young_ptr) LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) /* Test if backtrace is active */ - LOADGLOBAL(TMP, caml_backtrace_active) + LOADGLOBAL(TMP, caml_backtrace_active) cbnz TMP, 2f 1: /* Cut stack at current trap handler */ mov sp, TRAP_PTR /* Pop previous handler and jump to it */ - ldr TMP, [sp, 8] + ldr TMP, [sp, 8] ldr TRAP_PTR, [sp], 16 br TMP 2: /* Preserve exception bucket in callee-save register x19 */ @@ -443,12 +443,12 @@ caml_raise_exception: /* Stash the backtrace */ /* arg1: exn bucket, already in x0 */ LOADGLOBAL(x1, caml_last_return_address) /* arg2: pc of raise */ - LOADGLOBAL(x2, caml_bottom_of_stack) /* arg3: sp of raise */ + LOADGLOBAL(x2, caml_bottom_of_stack) /* arg3: sp of raise */ mov x3, TRAP_PTR /* arg4: sp of handler */ bl caml_stash_backtrace /* Restore exception bucket and raise */ mov x0, x19 - b 1b + b 1b CFI_ENDPROC .type caml_raise_exception, %function .size caml_raise_exception, .-caml_raise_exception @@ -461,7 +461,7 @@ caml_callback_exn: CFI_STARTPROC PROFILE /* Initial shuffling of arguments (x0 = closure, x1 = first arg) */ - mov TMP, x0 + mov TMP, x0 mov x0, x1 /* x0 = first arg */ mov x1, TMP /* x1 = closure environment */ ldr ARG, [TMP] /* code pointer */ @@ -476,11 +476,11 @@ caml_callback2_exn: CFI_STARTPROC PROFILE /* Initial shuffling of arguments (x0 = closure, x1 = arg1, x2 = arg2) */ - mov TMP, x0 + mov TMP, x0 mov x0, x1 /* x0 = first arg */ - mov x1, x2 /* x1 = second arg + mov x1, x2 /* x1 = second arg mov x2, TMP /* x2 = closure environment */ - ADDRGLOBAL(ARG, caml_apply2) + ADDRGLOBAL(ARG, caml_apply2) b .Ljump_to_caml CFI_ENDPROC .type caml_callback2_exn, %function @@ -498,7 +498,7 @@ caml_callback3_exn: mov x1, x2 /* x1 = second arg */ mov x2, x3 /* x2 = third arg */ mov x3, TMP /* x3 = closure environment */ - ADDRGLOBAL(ARG, caml_apply3) + ADDRGLOBAL(ARG, caml_apply3) b .Ljump_to_caml CFI_ENDPROC .type caml_callback3_exn, %function diff --git a/asmrun/fail.c b/asmrun/fail.c index a63a09ca05..be625e10e5 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -161,9 +161,11 @@ static value * caml_array_bound_error_exn = NULL; void caml_array_bound_error(void) { if (caml_array_bound_error_exn == NULL) { - caml_array_bound_error_exn = caml_named_value("Pervasives.array_bound_error"); + caml_array_bound_error_exn = + caml_named_value("Pervasives.array_bound_error"); if (caml_array_bound_error_exn == NULL) { - fprintf(stderr, "Fatal error: exception Invalid_argument(\"index out of bounds\")\n"); + fprintf(stderr, "Fatal error: exception " + "Invalid_argument(\"index out of bounds\")\n"); exit(2); } } diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S index dfbf5b97a3..facbfbf0e1 100644 --- a/asmrun/power-elf.S +++ b/asmrun/power-elf.S @@ -253,9 +253,9 @@ caml_reraise_exn: .globl caml_raise_exception .type caml_raise_exception, @function caml_raise_exception: - Loadglobal(0, caml_backtrace_active, 11) - cmpwi 0, 0 - bne .L121 + Loadglobal(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne .L121 .L120: /* Reload OCaml global registers */ Loadglobal(1, caml_exception_pointer, 11) @@ -274,8 +274,8 @@ caml_raise_exception: mr 28, 3 /* preserve exn bucket in callee-save reg */ /* arg1: exception bucket, already in r3 */ Loadglobal(4, caml_last_return_address, 11) /* arg2: PC of raise */ - Loadglobal(5, caml_bottom_of_stack, 11) /* arg3: SP of raise */ - Loadglobal(6, caml_exception_pointer, 11) /* arg4: SP of handler */ + Loadglobal(5, caml_bottom_of_stack, 11) /* arg3: SP of raise */ + Loadglobal(6, caml_exception_pointer, 11) /* arg4: SP of handler */ addi 1, 1, -16 /* reserve stack space for C call */ bl caml_stash_backtrace mr 3, 28 /* restore exn bucket */ diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S index a228cc1d53..6fcb43cc2d 100644 --- a/asmrun/power-rhapsody.S +++ b/asmrun/power-rhapsody.S @@ -255,9 +255,9 @@ L111: /* Branch to handler */ bctr L110: - li r0, 0 - Storeglobal32 r0, _caml_backtrace_pos, r11 -L114: + li r0, 0 + Storeglobal32 r0, _caml_backtrace_pos, r11 +L114: mr r28, r3 /* preserve exn bucket in callee-save */ /* arg 1: exception bucket (already in r3) */ mflr r4 /* arg 2: PC of raise */ @@ -282,7 +282,7 @@ _caml_reraise_exn: /* Branch to handler */ bctr - /* Raise an exception from C */ + /* Raise an exception from C */ .globl _caml_raise_exception _caml_raise_exception: diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 0cc62a1359..d306407875 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex a7d00ffcb5..5c8dabda77 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex f941bda27f..123a23b62f 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 90764de6b1..47349d6f35 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -409,6 +409,10 @@ let comp_primitive p args = let is_immed n = immed_min <= n && n <= immed_max +module Storer = + Switch.Store + (struct type t = lambda type key = lambda + let make_key = Lambda.make_key end) (* Compile an expression. The value of the expression is left in the accumulator. @@ -699,8 +703,9 @@ let rec comp_expr env exp sz cont = | Lswitch(arg, sw) -> let (branch, cont1) = make_branch cont in let c = ref (discard_dead_code cont1) in + (* Build indirection vectors *) - let store = mk_store Lambda.same in + let store = Storer.mk_store () in let act_consts = Array.create sw.sw_numconsts 0 and act_blocks = Array.create sw.sw_numblocks 0 in begin match sw.sw_failaction with (* default is index 0 *) @@ -713,6 +718,17 @@ let rec comp_expr env exp sz cont = (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks; (* Compile and label actions *) let acts = store.act_get () in +(* + let a = store.act_get_shared () in + Array.iter + (function + | Switch.Shared (Lstaticraise _) -> () + | Switch.Shared act -> + Printlambda.lambda Format.str_formatter act ; + Printf.eprintf "SHARE BYTE:\n%s\n" (Format.flush_str_formatter ()) + | _ -> ()) + a ; +*) let lbls = Array.create (Array.length acts) 0 in for i = Array.length acts-1 downto 0 do let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 9c9c1b842f..23582c1cb2 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -17,6 +17,8 @@ open Misc open Instruct open Cmo_format +module StringSet = Set.Make(String) + type error = Forward_reference of string * Ident.t | Multiple_definition of string * Ident.t @@ -30,6 +32,7 @@ exception Error of error let relocs = ref ([] : (reloc_info * int) list) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let primitives = ref ([] : string list) let force_link = ref false @@ -137,6 +140,10 @@ let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in ic compunit.cu_debug; List.iter (relocate_debug ofs prefix subst) (input_value ic); + debug_dirs := List.fold_left + (fun s e -> StringSet.add e s) + !debug_dirs + (input_value ic); end; close_in ic; compunit.cu_codesize @@ -215,6 +222,7 @@ let package_object_files ppf files targetfile targetname coercion = let pos_debug = pos_out oc in if !Clflags.debug && !events <> [] then output_value oc (List.rev !events); + output_value oc (StringSet.elements !debug_dirs); let pos_final = pos_out oc in let imports = List.filter diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 9911de8828..a56bf9175b 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -20,6 +20,8 @@ open Instruct open Opcodes open Cmo_format +module StringSet = Set.Make(String) + (* Buffering of bytecode *) let out_buffer = ref(LongString.create 1024) @@ -135,8 +137,12 @@ and slot_for_c_prim name = (* Debugging events *) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let record_event ev = + let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in + let abspath = Location.absolute_path path in + debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs; ev.ev_pos <- !out_position; events := ev :: !events @@ -146,6 +152,7 @@ let init () = out_position := 0; label_table := Array.create 16 (Label_undefined []); reloc_info := []; + debug_dirs := StringSet.empty; events := [] (* Emission of one instruction *) @@ -365,6 +372,7 @@ let to_file outchan unit_name code = if !Clflags.debug then begin let p = pos_out outchan in output_value outchan !events; + output_value outchan (StringSet.elements !debug_dirs); (p, pos_out outchan - p) end else (0, 0) in diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 83c00a32da..f68588090b 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -166,7 +174,7 @@ type lambda = | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list | Lswitch of lambda * lambda_switch - | Lstringswitch of lambda * (string * lambda) list * lambda + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -201,65 +209,83 @@ let const_unit = Const_pointer 0 let lambda_unit = Lconst const_unit -let rec same l1 l2 = - match (l1, l2) with - | Lvar v1, Lvar v2 -> - Ident.same v1 v2 - | Lconst (Const_base (Const_string _)), _ -> - false (* do not share strings *) - | Lconst c1, Lconst c2 -> - c1 = c2 - | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> - same a1 a2 && samelist same bl1 bl2 - | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> - k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 - | Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) -> - k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2 - | Lletrec (bl1, a1), Lletrec (bl2, a2) -> - samelist samebinding bl1 bl2 && same a1 a2 - | Lprim(p1, al1), Lprim(p2, al2) -> - p1 = p2 && samelist same al1 al2 - | Lswitch(a1, s1), Lswitch(a2, s2) -> - same a1 a2 && sameswitch s1 s2 - | Lstaticraise(n1, al1), Lstaticraise(n2, al2) -> - n1 = n2 && samelist same al1 al2 - | Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) -> - same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2 - | Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) -> - same a1 a2 && Ident.same id1 id2 && same b1 b2 - | Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) -> - same a1 a2 && same b1 b2 && same c1 c2 - | Lsequence(a1, b1), Lsequence(a2, b2) -> - same a1 a2 && same b1 b2 - | Lwhile(a1, b1), Lwhile(a2, b2) -> - same a1 a2 && same b1 b2 - | Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) -> - Ident.same id1 id2 && same a1 a2 && - same b1 b2 && df1 = df2 && same c1 c2 - | Lassign(id1, a1), Lassign(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) -> - k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2 - | Levent(a1, ev1), Levent(a2, ev2) -> - same a1 a2 && ev1.lev_loc = ev2.lev_loc - | Lifused(id1, a1), Lifused(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | _, _ -> - false - -and samebinding (id1, c1) (id2, c2) = - Ident.same id1 id2 && same c1 c2 - -and sameswitch sw1 sw2 = - let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in - sw1.sw_numconsts = sw2.sw_numconsts && - sw1.sw_numblocks = sw2.sw_numblocks && - samelist samecase sw1.sw_consts sw2.sw_consts && - samelist samecase sw1.sw_blocks sw2.sw_blocks && - (match (sw1.sw_failaction, sw2.sw_failaction) with - | (None, None) -> true - | (Some a1, Some a2) -> same a1 a2 - | _ -> false) +exception Not_simple + +let max_raw = 32 + +let make_key e = + let count = ref 0 + and make_key = Ident.make_key_generator () in + let rec tr_rec env e = + incr count ; + if !count > max_raw then raise Not_simple ; + match e with + | Lvar id -> + begin + try Ident.find_same id env + with Not_found -> e + end + | Lconst (Const_base (Const_string _)|Const_float_array _) -> + (* Mutable constants are not shared *) + raise Not_simple + | Lconst _ -> e + | Lapply (e,es,loc) -> + Lapply (tr_rec env e,tr_recs env es,Location.none) + | Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet (str,x,ex,e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str,y,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p,es) -> + Lprim (p,tr_recs env es) + | Lswitch (e,sw) -> + Lswitch (tr_rec env e,tr_sw env sw) + | Lstringswitch (e,sw,d) -> + Lstringswitch + (tr_rec env e, + List.map (fun (s,e) -> s,tr_rec env e) sw, + tr_opt env d) + | Lstaticraise (i,es) -> + Lstaticraise (i,tr_recs env es) + | Lstaticcatch (e1,xs,e2) -> + Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) + | Ltrywith (e1,x,e2) -> + Ltrywith (tr_rec env e1,x,tr_rec env e2) + | Lifthenelse (cond,ifso,ifnot) -> + Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) + | Lsequence (e1,e2) -> + Lsequence (tr_rec env e1,tr_rec env e2) + | Lassign (x,e) -> + Lassign (x,tr_rec env e) + | Lsend (m,e1,e2,es,loc) -> + Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) + | Levent (e,evt) -> + Levent (tr_rec env e,evt) + | Lifused (id,e) -> Lifused (id,tr_rec env e) + | Lletrec _|Lfunction _ + | Lfor _ | Lwhile _ -> + raise Not_simple + + and tr_recs env es = List.map (tr_rec env) es + + and tr_sw env sw = + { sw with + sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; + sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; + sw_failaction = tr_opt env sw.sw_failaction ; } + + and tr_opt env = function + | None -> None + | Some e -> Some (tr_rec env e) in + + try + Some (tr_rec Ident.empty e) + with Not_simple -> None + +(***************) let name_lambda strict arg fn = match arg with @@ -276,6 +302,11 @@ let name_lambda_list args fn = Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in name_list [] args + +let iter_opt f = function + | None -> () + | Some e -> f e + let iter f = function Lvar _ | Lconst _ -> () @@ -294,14 +325,11 @@ let iter f = function f arg; List.iter (fun (key, case) -> f case) sw.sw_consts; List.iter (fun (key, case) -> f case) sw.sw_blocks; - begin match sw.sw_failaction with - | None -> () - | Some l -> f l - end + iter_opt f sw.sw_failaction | Lstringswitch (arg,cases,default) -> f arg ; List.iter (fun (_,act) -> f act) cases ; - f default + iter_opt f default | Lstaticraise (_,args) -> List.iter f args | Lstaticcatch(e1, (_,vars), e2) -> @@ -325,6 +353,7 @@ let iter f = function | Lifused (v, e) -> f e + module IdentSet = Set.Make(struct type t = Ident.t @@ -401,7 +430,7 @@ let rec transl_normal_path = function (* Translation of value identifiers *) let transl_path ?(loc=Location.none) env path = - transl_normal_path (Env.normalize_path (Some loc) env path) + transl_normal_path (Env.normalize_path (Some loc) env path) (* Compile a sequence of expressions *) @@ -431,13 +460,10 @@ let subst_lambda s lam = Lswitch(subst arg, {sw with sw_consts = List.map subst_case sw.sw_consts; sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = - match sw.sw_failaction with - | None -> None - | Some l -> Some (subst l)}) + sw_failaction = subst_opt sw.sw_failaction; }) | Lstringswitch (arg,cases,default) -> Lstringswitch - (subst arg,List.map subst_strcase cases,subst default) + (subst arg,List.map subst_strcase cases,subst_opt default) | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) @@ -453,6 +479,9 @@ let subst_lambda s lam = and subst_decl (id, exp) = (id, subst exp) and subst_case (key, case) = (key, subst case) and subst_strcase (key, case) = (key, subst case) + and subst_opt = function + | None -> None + | Some e -> Some (subst e) in subst lam @@ -477,3 +506,26 @@ let raise_kind = function | Raise_regular -> "raise" | Raise_reraise -> "reraise" | Raise_notrace -> "raise_notrace" + +let lam_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let (file, lnum, cnum) = Location.get_pos_info loc_start in + let enum = loc.Location.loc_end.Lexing.pos_cnum - + loc_start.Lexing.pos_cnum + cnum in + match kind with + | Loc_POS -> + Lconst (Const_block (0, [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ])) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> Lconst (Const_immstring + (String.capitalize + (Filename.chop_extension (Filename.basename file)))) + | Loc_LOC -> + let loc = Printf.sprintf "File %S, line %d, characters %d-%d" + file lnum cnum enum in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 6748fefe1a..8acb4cd03e 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -177,7 +185,7 @@ type lambda = | Lswitch of lambda * lambda_switch (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) - | Lstringswitch of lambda * (string * lambda) list * lambda + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -207,7 +215,9 @@ and lambda_event_kind = | Lev_after of Types.type_expr | Lev_function -val same: lambda -> lambda -> bool +(* Sharing key *) +val make_key: lambda -> lambda option + val const_unit: structured_constant val lambda_unit: lambda val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda @@ -243,3 +253,4 @@ val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda val raise_kind: raise_kind -> string +val lam_of_loc : loc_kind -> Location.t -> lambda diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 3ec3611bad..b1036ec9a5 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -21,6 +21,7 @@ open Lambda open Parmatch open Printf + let dbg = false (* See Peyton-Jones, ``The Implementation of functional programming @@ -40,6 +41,10 @@ let dbg = false - Jump summaries: mapping from exit numbers to contexts *) +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + type matrix = pattern list list let add_omega_column pss = List.map (fun ps -> omega::ps) pss @@ -443,66 +448,96 @@ let pretty_precompiled_res first nexts = -(* A slight attempt to identify semantically equivalent lambda-expressions, - We could have used Lambda.same, but our goal here is also to +(* Identifing some semantically equivalent lambda-expressions, + Our goal here is also to find alpha-equivalent (simple) terms *) -exception Not_simple -let rec raw_rec env : lambda -> lambda = function - | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body - | Lvar id as l -> - begin try List.assoc id env with - | Not_found -> l - end - | Lprim (Pfield i,args) -> - Lprim (Pfield i, List.map (raw_rec env) args) - | Lconst (Const_base (Const_string _)) -> - raise Not_simple (* do not share strings *) - | Lconst _ as l -> l - | Lstaticraise (i,args) -> - Lstaticraise (i, List.map (raw_rec env) args) - | _ -> raise Not_simple +(* However, as shown by PR#6359 such sharing may hinders the + lambda-code invariant that all bound idents are unique, + when switchs are compiled to test sequences. + The definitive fix is the systematic introduction of exit/catch + in case action sharing is present. +*) + + +module StoreExp = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + + +let make_exit i = Lstaticraise (i,[]) + +(* Introduce a catch, if worth it *) +let make_catch d k = match d with +| Lstaticraise (_,[]) -> k d +| _ -> + let e = next_raise_count () in + Lstaticcatch (k (make_exit e),(e,[]),d) + +(* Introduce a catch, if worth it, delayed version *) +let rec as_simple_exit = function + | Lstaticraise (i,[]) -> Some i + | Llet (Alias,_,_,e) -> as_simple_exit e + | _ -> None + + +let make_catch_delayed handler = match as_simple_exit handler with +| Some i -> i,(fun act -> act) +| None -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); +*) + i, + (fun body -> match body with + | Lstaticraise (j,_) -> + if i=j then handler else body + | _ -> Lstaticcatch (body,(i,[]),handler)) + -let raw_action l = try raw_rec [] l with Not_simple -> l +let raw_action l = + match make_key l with | Some l -> l | None -> l + + +let tr_raw act = match make_key act with +| Some act -> act +| None -> raise Exit let same_actions = function | [] -> None | [_,act] -> Some act | (_,act0) :: rem -> try - let raw_act0 = raw_rec [] act0 in + let raw_act0 = tr_raw act0 in let rec s_rec = function | [] -> Some act0 | (_,act)::rem -> - if raw_act0 = raw_rec [] act then + if raw_act0 = tr_raw act then s_rec rem else None in s_rec rem with - | Not_simple -> None + | Exit -> None -let equal_action act1 act2 = - try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - raw1 = raw2 - with - | Not_simple -> false (* Test for swapping two clauses *) let up_ok_action act1 act2 = try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in + let raw1 = tr_raw act1 + and raw2 = tr_raw act2 in match raw1, raw2 with | Lstaticraise (i1,[]), Lstaticraise (i2,[]) -> i1=i2 | _,_ -> raw1 = raw2 with - | Not_simple -> false + | Exit -> false -(* Nothing is kown about exeception patterns, because of potential rebind *) +(* Nothing is kown about exception patterns, because of potential rebind *) let rec exc_inside p = match p.pat_desc with | Tpat_construct (_,{cstr_tag=Cstr_exception _},_) -> true | Tpat_any|Tpat_constant _|Tpat_var _ @@ -961,7 +996,7 @@ and split_naive cls args def k = | (p::_,_ as cl)::rem -> if group_constructor p then split_exc (pat_as_constr p) [cl] rem - else + else split_noexc [cl] rem | _ -> assert false @@ -1656,9 +1691,10 @@ let divide_array kind ctx pm = (make_array_matching kind) (=) get_key_array get_args_array ctx pm + (* Specific string test sequence - Will be called by the bytecode compiler, from bytegen.ml. + Will be called by the bytecode compiler, from bytegen.ml. The strategy is first dichotomic search (we perform 3-way tests with compare_string), then sequence of equality tests when there are less then T=strings_test_threshold static strings to match. @@ -1668,7 +1704,7 @@ let divide_array kind ctx pm = T=8 looks a decent tradeoff. *) -(* Utlities *) +(* Utilities *) let strings_test_threshold = 8 @@ -1687,11 +1723,18 @@ let bind_sw arg k = match arg with | _ -> let id = Ident.create "switch" in Llet (Strict,id,arg,k (Lvar id)) - - + + (* Sequential equality tests *) -let make_test_sequence arg sw d = +let make_string_test_sequence arg sw d = + let d,sw = match d with + | None -> + begin match sw with + | (_,d)::sw -> d,sw + | [] -> assert false + end + | Some d -> d,sw in bind_sw arg (fun arg -> List.fold_right @@ -1703,12 +1746,6 @@ let make_test_sequence arg sw d = k,lam)) sw d) -let catch_sw d k = match d with -| Lstaticraise (_,[]) -> k d -| _ -> - let e = next_raise_count () in - Lstaticcatch (k (Lstaticraise (e,[])),(e,[]),d) - let rec split k xs = match xs with | [] -> assert false | x0::xs -> @@ -1726,9 +1763,11 @@ let tree_way_test arg lt eq gt = (* Dichotomic tree *) -let rec do_make_tree arg sw d = + +let rec do_make_string_test_tree arg sw delta d = let len = List.length sw in - if len <= strings_test_threshold then make_test_sequence arg sw d + if len <= strings_test_threshold+delta then + make_string_test_sequence arg sw d else let lt,(s,act),gt = split len sw in bind_sw @@ -1737,17 +1776,64 @@ let rec do_make_tree arg sw d = [arg; Lconst (Const_immstring s)];)) (fun r -> tree_way_test r - (do_make_tree arg lt d) + (do_make_string_test_tree arg lt delta d) act - (do_make_tree arg gt d)) - -(* Entry point *) -let expand_stringswitch arg sw d = - bind_sw arg (fun arg -> catch_sw d (fun d -> do_make_tree arg sw d)) + (do_make_string_test_tree arg gt delta d)) -(*************************************) -(* To combine sub-matchings together *) -(*************************************) +(* Entry point *) +let expand_stringswitch arg sw d = match d with +| None -> + bind_sw arg + (fun arg -> do_make_string_test_tree arg sw 0 None) +| Some e -> + bind_sw arg + (fun arg -> + make_catch e + (fun d -> do_make_string_test_tree arg sw 1 (Some d))) + +(**********************) +(* Generic test trees *) +(**********************) + +(* Sharing *) + +(* Add handler, if shared *) +let handle_shared () = + let hs = ref (fun x -> x) in + let handle_shared act = match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i,h = make_catch_delayed act in + let ohs = !hs in + hs := (fun act -> h (ohs act)) ; + make_exit i in + hs,handle_shared + + +let share_actions_tree sw d = + let store = StoreExp.mk_store () in +(* Default action is always shared *) + let d = + match d with + | None -> None + | Some d -> Some (store.Switch.act_store_shared d) in +(* Store all other actions *) + let sw = + List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in + +(* Retrieve all actions, includint potentiel default *) + let acts = store.Switch.act_get_shared () in + +(* Array of actual actions *) + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + +(* Recontruct default and switch list *) + let d = match d with + | None -> None + | Some d -> Some (acts.(d)) in + let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in + !hs,sw,d (* Note: dichotomic search requires sorted input with no duplicates *) let rec uniq_lambda_list sw = match sw with @@ -1785,6 +1871,10 @@ let rec do_tests_nofail tst arg = function act) let make_test_sequence fail tst lt_tst arg const_lambda_list = + let const_lambda_list = sort_lambda_list const_lambda_list in + let hs,const_lambda_list,fail = + share_actions_tree const_lambda_list fail in + let rec make_test_sequence const_lambda_list = if List.length const_lambda_list >= 4 && lt_tst <> Pignore then split_sequence const_lambda_list @@ -1797,10 +1887,9 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list = cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]), make_test_sequence list1, make_test_sequence list2) - in make_test_sequence (sort_lambda_list const_lambda_list) - + in + hs (make_test_sequence const_lambda_list) -let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) let rec explode_inter offset i j act k = if i <= j then @@ -1842,65 +1931,6 @@ let as_int_list cases acts = (if default >= 0 then Some acts.(default) else None) -let make_switch_offset arg min_key max_key int_lambda_list default = - let numcases = max_key - min_key + 1 in - let cases = - List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in - let offsetarg = make_offset (-min_key) arg in - Lswitch(offsetarg, - {sw_numconsts = numcases; sw_consts = cases; - sw_numblocks = 0; sw_blocks = []; - sw_failaction = default}) - -let make_switch_switcher arg cases acts = - let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None}) - -let full sw = - List.length sw.sw_consts = sw.sw_numconsts && - List.length sw.sw_blocks = sw.sw_numblocks - -let make_switch (arg,sw) = match sw.sw_failaction with -| None -> - let t = Hashtbl.create 17 in - let seen l = match l with - | Lstaticraise (i,[]) -> - let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) - | _ -> () in - List.iter (fun (_,lam) -> seen lam) sw.sw_consts ; - List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in - Hashtbl.iter - (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; - if !i_max >= 0 then - let default = !i_max in - let rec remove = function - | [] -> [] - | (_,Lstaticraise (j,[]))::rem when j=default -> - remove rem - | x::rem -> x::remove rem in - Lswitch - (arg, - {sw with -sw_consts = remove sw.sw_consts ; -sw_blocks = remove sw.sw_blocks ; -sw_failaction = Some (Lstaticraise (default,[]))}) - else - Lswitch (arg,sw) -| _ -> Lswitch (arg,sw) - module SArg = struct type primitive = Lambda.primitive @@ -1917,6 +1947,7 @@ module SArg = struct let make_offset arg n = match n with | 0 -> arg | _ -> Lprim (Poffsetint n,[arg]) + let bind arg body = let newvar,newarg = match arg with | Lvar v -> v,arg @@ -1924,13 +1955,89 @@ module SArg = struct let newvar = Ident.create "switcher" in newvar,Lvar newvar in bind Alias newvar arg (body newarg) - + let make_const i = Lconst (Const_base (Const_int i)) let make_isout h arg = Lprim (Pisout, [h ; arg]) let make_isin h arg = Lprim (Pnot,[make_isout h arg]) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch = make_switch_switcher + let make_switch arg cases acts = + let l = ref [] in + for i = Array.length cases-1 downto 0 do + l := (i,acts.(cases.(i))) :: !l + done ; + Lswitch(arg, + {sw_numconsts = Array.length cases ; sw_consts = !l ; + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}) + let make_catch = make_catch_delayed + let make_exit = make_exit + end +(* Action sharing for Lswitch argument *) +let share_actions_sw sw = +(* Attempt sharing on all actions *) + let store = StoreExp.mk_store () in + let fail = match sw.sw_failaction with + | None -> None + | Some fail -> + (* Fail is translated to exit, whatever happens *) + Some (store.Switch.act_store_shared fail) in + let consts = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_consts + and blocks = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_blocks in + let acts = store.Switch.act_get_shared () in + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + let fail = match fail with + | None -> None + | Some fail -> Some (acts.(fail)) in + !hs, + { sw with + sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; + sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; + sw_failaction = fail; } + +(* Reintroduce fail action in switch argument, + for the sake of avoiding carrying over huge switches *) + +let reintroduce_fail sw = match sw.sw_failaction with +| None -> + let t = Hashtbl.create 17 in + let seen (_,l) = match as_simple_exit l with + | Some i -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) + | None -> () in + List.iter seen sw.sw_consts ; + List.iter seen sw.sw_blocks ; + let i_max = ref (-1) + and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if c > !max then begin + i_max := i ; + max := c + end) t ; + if !max >= 3 then + let default = !i_max in + let remove = + List.filter + (fun (_,lam) -> match as_simple_exit lam with + | Some j -> j <> default + | None -> true) in + {sw with + sw_consts = remove sw.sw_consts ; + sw_blocks = remove sw.sw_blocks ; + sw_failaction = Some (make_exit default)} + else sw +| Some _ -> sw + + module Switcher = Switch.Make(SArg) open Switch @@ -1947,7 +2054,16 @@ let get_edges low high l = match l with let as_interval_canfail fail low high l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in + + let do_store tag act = + let i = store.act_store act in +(* + Printlambda.lambda Format.str_formatter act ; + eprintf "STORE [%s] %i %s\n" tag i (Format.flush_str_formatter ()) ; +*) + i in + let rec nofail_rec cur_low cur_high cur_act = function | [] -> if cur_high = high then @@ -1955,7 +2071,7 @@ let as_interval_canfail fail low high l = else [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] | ((i,act_i)::rem) as all -> - let act_index = store.act_store act_i in + let act_index = do_store "NO" act_i in if cur_high+1= i then if act_index=cur_act then nofail_rec cur_low i cur_act rem @@ -1963,14 +2079,18 @@ let as_interval_canfail fail low high l = (cur_low,i-1, cur_act)::fail_rec i i rem else (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act):: + fail_rec (cur_high+1) (cur_high+1) all else (cur_low, cur_high, cur_act):: - fail_rec ((cur_high+1)) (cur_high+1) all + (cur_high+1,i-1,0):: + nofail_rec i i act_index rem and fail_rec cur_low cur_high = function | [] -> [(cur_low, cur_high, 0)] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "YES" act_i in if index=0 then fail_rec cur_low i rem else (cur_low,i-1,0):: @@ -1979,7 +2099,7 @@ let as_interval_canfail fail low high l = let init_rec = function | [] -> [] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "INIT" act_i in if index=0 then fail_rec low i rem else @@ -1988,12 +2108,12 @@ let as_interval_canfail fail low high l = else nofail_rec i i index rem in - ignore (store.act_store fail) ; (* fail has action index 0 *) + assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) let r = init_rec l in - Array.of_list r, store.act_get () + Array.of_list r, store let as_interval_nofail l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in let rec i_rec cur_low cur_high cur_act = function | [] -> @@ -2011,7 +2131,7 @@ let as_interval_nofail l = i_rec i i act_index rem | _ -> assert false in - Array.of_list inters, store.act_get () + Array.of_list inters, store let sort_int_lambda_list l = @@ -2029,10 +2149,10 @@ let as_interval fail low high l = | None -> as_interval_nofail l | Some act -> as_interval_canfail act low high l) -let call_switcher konst fail arg low high int_lambda_list = +let call_switcher fail arg low high int_lambda_list = let edges, (cases, actions) = as_interval fail low high int_lambda_list in - Switcher.zyva edges konst arg cases actions + Switcher.zyva edges arg cases actions let exists_ctx ok ctx = @@ -2187,33 +2307,27 @@ let combine_constant arg cst partial ctx def let int_lambda_list = List.map (function Const_int n, l -> n,l | _ -> assert false) const_lambda_list in - call_switcher - lambda_of_int fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list | Const_char _ -> let int_lambda_list = List.map (function Const_char c, l -> (Char.code c, l) | _ -> assert false) const_lambda_list in - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg 0 255 int_lambda_list + call_switcher fail arg 0 255 int_lambda_list | Const_string _ -> (* Note as the bytecode compiler may resort to dichotmic search, the clauses of strinswitch are sorted with duplicate removed. This partly applies to the native code compiler, which requires - no duplicates *) - let fail,const_lambda_list = match fail with - | Some fail -> fail,sort_lambda_list const_lambda_list - | None -> - let cls,(_,lst) = Misc.split_last const_lambda_list in - lst,sort_lambda_list cls in + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in let sw = List.map (fun (c,act) -> match c with | Const_string (s,_) -> s,act | _ -> assert false) const_lambda_list in - Lstringswitch (arg,sw,fail) + let hs,sw,fail = share_actions_tree sw fail in + hs (Lstringswitch (arg,sw,fail)) | Const_float _ -> make_test_sequence fail @@ -2307,22 +2421,22 @@ let combine_constructor arg ex_pat cstr partial ctx def | (1, 1, [0, act1], [0, act2]) -> Lifthenelse(arg, act2, act1) | (n,_,_,[]) -> - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - None arg 0 (n-1) consts + call_switcher None arg 0 (n-1) consts | (n, _, _, _) -> match same_actions nonconsts with | None -> - make_switch(arg, {sw_numconsts = cstr.cstr_consts; - sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; - sw_blocks = nonconsts; - sw_failaction = None}) +(* Emit a switch, as bytecode implements this sophisticated instruction *) + let sw = + {sw_numconsts = cstr.cstr_consts; sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; + sw_failaction = None} in + let hs,sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg,sw)) | Some act -> Lifthenelse (Lprim (Pisint, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) None arg 0 (n-1) consts, act) in @@ -2332,20 +2446,16 @@ let combine_constructor arg ex_pat cstr partial ctx def let make_test_sequence_variant_constant fail arg int_lambda_list = let _, (cases, actions) = as_interval fail min_int max_int int_lambda_list in - Switcher.test_sequence - (fun i -> Lconst (Const_base (Const_int i))) arg cases actions + Switcher.test_sequence arg cases actions let call_switcher_variant_constant fail arg int_lambda_list = - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list let call_switcher_variant_constr fail arg int_lambda_list = let v = Ident.create "variant" in Llet(Alias, v, Lprim(Pfield 0, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) fail (Lvar v) min_int max_int int_lambda_list) let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = @@ -2409,7 +2519,6 @@ let combine_array arg kind partial ctx def let newvar = Ident.create "len" in let switch = call_switcher - lambda_of_int fail (Lvar newvar) 0 max_int len_lambda_list in bind @@ -2528,10 +2637,6 @@ let rec approx_present v = function | Lvar vv -> Ident.same v vv | _ -> true -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; - Format.flush_str_formatter () - let rec lower_bind v arg lam = match lam with | Lifthenelse (cond, ifso, ifnot) -> let pcond = approx_present v cond diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 398143778b..88002e0567 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -37,13 +37,7 @@ exception Cannot_flatten val flatten_pattern: int -> pattern -> pattern list (* Expand stringswitch to string test tree *) - -val expand_stringswitch: lambda -> (string * lambda) list -> lambda -> lambda - -(* -val make_test_sequence: - lambda option -> primitive -> primitive -> lambda -> - (Asttypes.constant * lambda) list -> lambda -*) +val expand_stringswitch: + lambda -> (string * lambda) list -> lambda option -> lambda val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 7e9c197e3f..006c8e2798 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -89,11 +89,19 @@ let record_rep ppf r = | Record_exception p -> fprintf ppf "exn (%s)" (Path.name p) ;; +let string_of_loc_kind = function + | Loc_FILE -> "loc_FILE" + | Loc_LINE -> "loc_LINE" + | Loc_MODULE -> "loc_MODULE" + | Loc_POS -> "loc_POS" + | Loc_LOC -> "loc_LOC" + let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pignore -> fprintf ppf "ignore" | Prevapply _ -> fprintf ppf "revapply" | Pdirapply _ -> fprintf ppf "dirapply" + | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag @@ -313,8 +321,12 @@ let rec lam ppf = function if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" (String.escaped s) lam l) cases; - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<hv 1>default:@ %a@]" lam default in + begin match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<hv 1>default:@ %a@]" lam default + | None -> () + end in fprintf ppf "@[<1>(stringswitch %a@ @[<v 0>%a@])@]" lam arg switch cases | Lstaticraise (i, ls) -> diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index c03cd857e7..85f0d71f9d 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -51,14 +51,13 @@ let rec eliminate_ref id = function sw_numblocks = sw.sw_numblocks; sw_blocks = List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; - sw_failaction = match sw.sw_failaction with - | None -> None - | Some l -> Some (eliminate_ref id l)}) + sw_failaction = + Misc.may_map (eliminate_ref id) sw.sw_failaction; }) | Lstringswitch(e, sw, default) -> Lstringswitch (eliminate_ref id e, List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, - eliminate_ref id default) + Misc.may_map (eliminate_ref id) default) | Lstaticraise (i,args) -> Lstaticraise (i,List.map (eliminate_ref id) args) | Lstaticcatch(e1, i, e2) -> @@ -123,7 +122,12 @@ let simplify_exits lam = | Lstringswitch(l, sw, d) -> count l; List.iter (fun (_, l) -> count l) sw; - count d + begin match d with + | None -> () + | Some d -> match sw with + | []|[_] -> count d + | _ -> count d; count d (* default will get replicated *) + end | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> (* i will be replaced by j in l1, so each occurence of i in l1 @@ -147,10 +151,7 @@ let simplify_exits lam = | Lsequence(l1, l2) -> count l1; count l2 | Lwhile(l1, l2) -> count l1; count l2 | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 - | Lassign(v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcount *) - count l + | Lassign(v, l) -> count l | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> count l @@ -218,16 +219,15 @@ let simplify_exits lam = let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) | Lstringswitch(l,sw,d) -> Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d) + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,[]) as l -> begin try let _,handler = Hashtbl.find subst i in @@ -253,13 +253,6 @@ let simplify_exits lam = | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; simplif l1 - | Lstaticcatch (l1,(i,xs), (Lvar _ as l2)) -> - begin match count_exit i with - | 0 -> simplif l1 - | _ -> - Hashtbl.add subst i (xs,l2) ; - simplif l1 - end | Lstaticcatch (l1,(i,xs),l2) -> begin match count_exit i with | 0 -> simplif l1 @@ -376,7 +369,14 @@ let simplify_lets lam = | Lstringswitch(l, sw, d) -> count bv l ; List.iter (fun (_, l) -> count bv l) sw ; - count bv d + begin match d with + | Some d -> + begin match sw with + | []|[_] -> count bv d + | _ -> count bv d ; count bv d + end + | None -> () + end | Lstaticraise (i,ls) -> List.iter (count bv) ls | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2 | Ltrywith(l1, v, l2) -> count bv l1; count bv l2 @@ -469,16 +469,15 @@ let simplify_lets lam = let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) | Lstringswitch (l,sw,d) -> Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d) + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,ls) -> Lstaticraise (i, List.map simplif ls) | Lstaticcatch(l1, (i,args), l2) -> @@ -539,13 +538,14 @@ let rec emit_tail_infos is_tail lambda = | Lswitch (lam, sw) -> emit_tail_infos false lam; list_emit_tail_infos_fun snd is_tail sw.sw_consts; - list_emit_tail_infos_fun snd is_tail sw.sw_blocks + list_emit_tail_infos_fun snd is_tail sw.sw_blocks; + Misc.may (emit_tail_infos is_tail) sw.sw_failaction | Lstringswitch (lam, sw, d) -> emit_tail_infos false lam; List.iter (fun (_,lam) -> emit_tail_infos is_tail lam) sw ; - emit_tail_infos is_tail d + Misc.may (emit_tail_infos is_tail) d | Lstaticraise (_, l) -> list_emit_tail_infos false l | Lstaticcatch (body, _, handler) -> diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index ff193ee132..4a4e0691c8 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -10,31 +10,81 @@ (* *) (***********************************************************************) -(* Store for actions in object style *) -exception Found of int + +type 'a shared = Shared of 'a | Single of 'a + +let share_out = function + | Shared act|Single act -> act + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} - -let mk_store same = - let r_acts = ref [] in - let store act = - let rec store_rec i = function - | [] -> i,[act] - | act0::rem -> - if same act0 act then raise (Found i) - else - let i,rem = store_rec (i+1) rem in - i,act0::rem in - try - let i,acts = store_rec 0 !r_acts in - r_acts := acts ; - i - with - | Found i -> i + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } - and get () = Array.of_list !r_acts in - {act_store=store ; act_get=get} +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) = struct + module AMap = + Map.Make(struct type t = A.key let compare = Pervasives.compare end) + + type intern = + { mutable map : (bool * int) AMap.t ; + mutable next : int ; + mutable acts : (bool * A.t) list; } + + let mk_store () = + let st = + { map = AMap.empty ; + next = 0 ; + acts = [] ; } in + + let add mustshare act = + let i = st.next in + st.acts <- (mustshare,act) :: st.acts ; + st.next <- i+1 ; + i in + + let store mustshare act = match A.make_key act with + | Some key -> + begin try + let (shared,i) = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true,i) st.map ; + i + with Not_found -> + let i = add mustshare act in + st.map <- AMap.add key (mustshare,i) st.map ; + i + end + | None -> + add mustshare act + + and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) + + and get_shared () = + let acts = + Array.of_list + (List.rev_map + (fun (shared,act) -> + if shared then Shared act else Single act) + st.acts) in + AMap.iter + (fun _ (shared,i) -> + if shared then match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map ; + acts in + {act_store = store false ; act_store_shared = store true ; + act_get = get; act_get_shared = get_shared; } +end @@ -50,13 +100,15 @@ module type S = type act val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act val make_isin : act -> act -> act val make_if : act -> act -> act -> act - val make_switch : - act -> int array -> act array -> act + val make_switch : act -> int array -> act array -> act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act end (* The module will ``produce good code for the case statement'' *) @@ -489,77 +541,77 @@ and enum top cases = end ; !r, !rc - let make_if_test konst test arg i ifso ifnot = + let make_if_test test arg i ifso ifnot = Arg.make_if - (Arg.make_prim test [arg ; konst i]) + (Arg.make_prim test [arg ; Arg.make_const i]) ifso ifnot - let make_if_lt konst arg i ifso ifnot = match i with + let make_if_lt arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.leint arg 0 ifso ifnot + make_if_test Arg.leint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.ltint arg i ifso ifnot + make_if_test Arg.ltint arg i ifso ifnot - and make_if_le konst arg i ifso ifnot = match i with + and make_if_le arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.ltint arg 0 ifso ifnot + make_if_test Arg.ltint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.leint arg i ifso ifnot + make_if_test Arg.leint arg i ifso ifnot - and make_if_gt konst arg i ifso ifnot = match i with + and make_if_gt arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.geint arg 0 ifso ifnot + make_if_test Arg.geint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.gtint arg i ifso ifnot + make_if_test Arg.gtint arg i ifso ifnot - and make_if_ge konst arg i ifso ifnot = match i with + and make_if_ge arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.gtint arg 0 ifso ifnot + make_if_test Arg.gtint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.geint arg i ifso ifnot + make_if_test Arg.geint arg i ifso ifnot - and make_if_eq konst arg i ifso ifnot = - make_if_test konst Arg.eqint arg i ifso ifnot + and make_if_eq arg i ifso ifnot = + make_if_test Arg.eqint arg i ifso ifnot - and make_if_ne konst arg i ifso ifnot = - make_if_test konst Arg.neint arg i ifso ifnot + and make_if_ne arg i ifso ifnot = + make_if_test Arg.neint arg i ifso ifnot let do_make_if_out h arg ifso ifno = Arg.make_if (Arg.make_isout h arg) ifso ifno - let make_if_out konst ctx l d mk_ifso mk_ifno = match l with + let make_if_out ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_out - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_out - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) let do_make_if_in h arg ifso ifno = Arg.make_if (Arg.make_isin h arg) ifso ifno - let make_if_in konst ctx l d mk_ifso mk_ifno = match l with + let make_if_in ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_in - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_in - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) - + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - let rec c_test konst ctx ({cases=cases ; actions=actions} as s) = + let rec c_test ctx ({cases=cases ; actions=actions} as s) = let lcases = Array.length cases in assert(lcases > 0) ; if lcases = 1 then actions.(get_act cases 0) ctx + else begin let w,c = opt_count false cases in @@ -579,31 +631,31 @@ and enum top cases = if low=high then begin if less_tests coutside cinside then make_if_eq - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=inside}) - (c_test konst ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) else make_if_ne - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=outside}) - (c_test konst ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) end else begin if less_tests coutside cinside then make_if_in - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=inside}) - (fun ctx -> c_test konst ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) else make_if_out - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=outside}) - (fun ctx -> c_test konst ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) end | Sep i -> let lim,left,right = coupe cases i in @@ -613,17 +665,17 @@ and enum top cases = and right = {s with cases=right} in if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne konst + make_if_ne ctx.arg 0 - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) else if less_tests cright cleft then - make_if_lt konst + make_if_lt ctx.arg (lim+ctx.off) - (c_test konst ctx left) (c_test konst ctx right) + (c_test ctx left) (c_test ctx right) else - make_if_ge konst + make_if_ge ctx.arg (lim+ctx.off) - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) end @@ -774,7 +826,7 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = ;; -let zyva (low,high) konst arg cases actions = +let do_zyva (low,high) arg cases actions = let old_ok = !ok_inter in ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -787,12 +839,31 @@ let zyva (low,high) konst arg cases actions = *) let n_clusters,k = comp_clusters s in let clusters = make_clusters s n_clusters k in - let r = c_test konst {arg=arg ; off=0} clusters in + let r = c_test {arg=arg ; off=0} clusters in r - - -and test_sequence konst arg cases actions = +let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> match act with + | Single act -> act + | Shared act -> + let i,h = Arg.make_catch act in + let oh = !handlers in + handlers := (fun act -> h (oh act)) ; + Arg.make_exit i) + actions in + !handlers,actions + +let zyva lh arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + hs (do_zyva lh arg cases actions) + +and test_sequence arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in let old_ok = !ok_inter in ok_inter := false ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -804,8 +875,7 @@ and test_sequence konst arg cases actions = pcases stderr cases ; prerr_endline "" ; *) - let r = c_test konst {arg=arg ; off=0} s in - r + hs (c_test {arg=arg ; off=0} s) ;; end diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli index 69fc800d38..53fd997485 100644 --- a/bytecomp/switch.mli +++ b/bytecomp/switch.mli @@ -17,9 +17,35 @@ (* For detecting action sharing, object style *) +(* Store for actions in object style: + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit +*) + +type 'a shared = Shared of 'a | Single of 'a + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} -val mk_store : ('a -> 'a -> bool) -> 'a t_store + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) : + sig + val mk_store : unit -> A.t t_store + end (* Arguments to the Make functor *) module type S = @@ -39,6 +65,7 @@ module type S = (* Various constructors, for making a binder, adding one integer, etc. *) val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act @@ -49,12 +76,15 @@ module type S = NB: cases is in the value form *) val make_switch : act -> int array -> act array -> act + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act + end (* - Make.zyva mk_const arg low high cases actions where - - mk_const takes an integer sends a constant action. + Make.zyva arg low high cases actions where - arg is the argument of the switch. - low, high are the interval limits. - cases is a list of sub-interval and action indices @@ -66,17 +96,18 @@ module type S = module Make : functor (Arg : S) -> sig +(* Standard entry point, sharing is tracked *) val zyva : (int * int) -> - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act + +(* Output test sequence, sharing tracked *) val test_sequence : - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act end diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 55ddab3bc8..72022a5e3a 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -116,7 +116,7 @@ let name_pattern default p = | _ -> Ident.create default let normalize_cl_path cl path = - Env.normalize_path (Some cl.cl_loc) cl.cl_env path + Env.normalize_path (Some cl.cl_loc) cl.cl_env path let rec build_object_init cl_table obj params inh_init obj_init cl = match cl.cl_desc with @@ -280,7 +280,9 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) | Tcf_val (name, _, id, _, over) -> - let values = if over then values else (name.txt, id) :: values in + let values = + if over then values else (name.txt, id) :: values + in (inh_init, cl_init, methods, values) | Tcf_method (_, _, Tcfk_virtual _) | Tcf_constraint _ @@ -296,7 +298,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = else met_code in (inh_init, cl_init, - Lvar (Meths.find name.txt str.cstr_meths) :: met_code @ methods, + Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, values) | Tcf_initializer exp -> (inh_init, diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index a2d15bf775..0df2c9ce2d 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -325,6 +325,11 @@ let find_primitive loc prim_name = match prim_name with "%revapply" -> Prevapply loc | "%apply" -> Pdirapply loc + | "%loc_LOC" -> Ploc Loc_LOC + | "%loc_FILE" -> Ploc Loc_FILE + | "%loc_LINE" -> Ploc Loc_LINE + | "%loc_POS" -> Ploc Loc_POS + | "%loc_MODULE" -> Ploc Loc_MODULE | name -> Hashtbl.find primitives_table name let transl_prim loc prim args = @@ -404,10 +409,20 @@ let transl_primitive loc p = with Not_found -> Pccall p in match prim with - Plazyforce -> + | Plazyforce -> let parm = Ident.create "prim" in Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + | Ploc kind -> + let lam = lam_of_loc kind loc in + begin match p.prim_arity with + | 0 -> lam + | 1 -> (* TODO: we should issue a warning ? *) + let param = Ident.create "prim" in + Lfunction(Curried, [param], + Lprim(Pmakeblock(0, Immutable), [lam; Lvar param])) + | _ -> assert false + end | _ -> let rec make_params n = if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in @@ -510,12 +525,14 @@ let rec push_defaults loc bindings cases partial = [{c_lhs=pat; c_guard=None; c_rhs={exp_desc = Texp_function(l, pl,partial)} as exp}] -> let pl = push_defaults exp.exp_loc bindings pl partial in - [{c_lhs=pat; c_guard=None; c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}] + [{c_lhs=pat; c_guard=None; + c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}] | [{c_lhs=pat; c_guard=None; c_rhs={exp_attributes=[{txt="#default"},_]; exp_desc = Texp_let (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> - push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] partial + push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial | [case] -> let exp = List.fold_left @@ -539,7 +556,9 @@ let rec push_defaults loc bindings cases partial = cases, partial) } in push_defaults loc bindings - [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; c_guard=None; c_rhs=exp}] Total + [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; + c_guard=None; c_rhs=exp}] + Total | _ -> cases @@ -694,6 +713,12 @@ and transl_exp0 e = k in wrap0 (Lprim(Praise k, [event_after arg1 targ])) + | (Ploc kind, []) -> + lam_of_loc kind e.exp_loc + | (Ploc kind, [arg1]) -> + let lam = lam_of_loc kind arg1.exp_loc in + Lprim(Pmakeblock(0, Immutable), lam :: argl) + | (Ploc _, _) -> assert false | (_, _) -> begin match (prim, argl) with | (Plazyforce, [a]) -> diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 4b3141ad90..3b4112b3e1 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -454,7 +454,8 @@ let rec defined_idents = function | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem | Tstr_class_type cl_list -> defined_idents rem - | Tstr_include(modl, sg, _) -> bound_value_identifiers sg @ defined_idents rem + | Tstr_include(modl, sg, _) -> + bound_value_identifiers sg @ defined_idents rem | Tstr_attribute _ -> defined_idents rem (* second level idents (module M = struct ... let id = ... end), @@ -868,7 +869,7 @@ let transl_store_package component_names target_name coercion = [Lprim(Pgetglobal target_name, []); Lprim(Pfield pos, [Lvar blk])])) 0 pos_cc_list)) - (* + (* (* ignore id_pos_list as the ids are already bound *) let id = Array.of_list component_names in (List.length pos_cc_list, diff --git a/byterun/Makefile b/byterun/Makefile index 3ff1654582..816dd75e51 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -46,7 +46,7 @@ libcamlrun_shared.so: $(PICOBJS) install:: if test -f libcamlrun_shared.so; then \ - cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so; fi + cp libcamlrun_shared.so $(INSTALL_LIBDIR)/libcamlrun_shared.so; fi clean:: rm -f libcamlrun_shared.so diff --git a/byterun/Makefile.common b/byterun/Makefile.common index 35e6650665..d2db39fe40 100755 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -48,15 +48,22 @@ ld.conf: ../config/Makefile echo "$(STUBLIBDIR)" > ld.conf echo "$(LIBDIR)" >> ld.conf +# Installation + +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + + install:: - cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) - cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) - cd $(LIBDIR); $(RANLIB) libcamlrun.$(A) - if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi + cp ocamlrun$(EXE) $(INSTALL_BINDIR)/ocamlrun$(EXE) + cp libcamlrun.$(A) $(INSTALL_LIBDIR)/libcamlrun.$(A) + cd $(INSTALL_LIBDIR); $(RANLIB) libcamlrun.$(A) + if test -d $(INSTALL_LIBDIR)/caml; then : ; \ + else mkdir $(INSTALL_LIBDIR)/caml; fi for i in $(PUBLIC_INCLUDES); do \ - sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ + sed -f ../tools/cleanup-header $$i > $(INSTALL_LIBDIR)/caml/$$i; \ done - cp ld.conf $(LIBDIR)/ld.conf + cp ld.conf $(INSTALL_LIBDIR)/ld.conf .PHONY: install install:: install-$(RUNTIMED) @@ -65,8 +72,8 @@ install-noruntimed: .PHONY: install-noruntimed install-runtimed: - cp ocamlrund$(EXE) $(BINDIR)/ocamlrund$(EXE) - cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A) + cp ocamlrund$(EXE) $(INSTALL_BINDIR)/ocamlrund$(EXE) + cp libcamlrund.$(A) $(INSTALL_LIBDIR)/libcamlrund.$(A) .PHONY: install-runtimed # If primitives contain duplicated lines (e.g. because the code is defined diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 1d4fb1e07e..d39e395290 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -229,6 +229,7 @@ static value read_debug_info(void) for (i = 0; i < num_events; i++) { orig = caml_getword(chan); evl = caml_input_val(chan); + caml_input_val(chan); // Skip the list of absolute directory names /* Relocate events in event list */ for (l = evl; l != Val_int(0); l = Field(l, 1)) { value ev = Field(l, 0); diff --git a/byterun/exec.h b/byterun/exec.h index 27f291ec59..a58bcf8b39 100644 --- a/byterun/exec.h +++ b/byterun/exec.h @@ -54,7 +54,7 @@ struct exec_trailer { /* Magic number for this release */ -#define EXEC_MAGIC "Caml1999X010" +#define EXEC_MAGIC "Caml1999X011" #endif /* CAML_EXEC_H */ diff --git a/byterun/osdeps.h b/byterun/osdeps.h index ee0952ac14..8204205f74 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -61,7 +61,8 @@ extern char * caml_dlerror(void); Return 0 on success, -1 on error; set errno in the case of error. */ extern int caml_read_directory(char * dirname, struct ext_table * contents); -/* Recover executable name if possible (/proc/sef/exe under Linux, GetModuleFileName under Windows). */ +/* Recover executable name if possible (/proc/sef/exe under Linux, + GetModuleFileName under Windows). */ extern int caml_executable_name(char * name, int name_len); #endif /* CAML_OSDEPS_H */ diff --git a/byterun/startup.c b/byterun/startup.c index 80ffe90b5d..4bff11a0dc 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -374,7 +374,8 @@ CAMLexport void caml_main(char **argv) /* Should we really do that at all? The current executable is ocamlrun itself, it's never a bytecode program. */ - if (fd < 0 && caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) { + if (fd < 0 + && caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) { exe_name = proc_self_exe; fd = caml_attempt_open(&exe_name, &trail, 0); } @@ -322,7 +322,7 @@ case "$bytecc,$target" in bytecccompopts="-fno-defer-pop $gcc_warnings -DSHRINKED_GNUC" mathlib="";; *,*-*-darwin*) - bytecccompopts="-fno-defer-pop $gcc_warnings" + bytecccompopts="$gcc_warnings" mathlib="" mkexe="$mkexe -Wl,-no_compact_unwind" # Tell gcc that we can use 32-bit code addresses for threaded code diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index d85419eb0c..249e8b4c40 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -12,7 +12,8 @@ include ../config/Makefile -CAMLC=../ocamlcomp.sh +ROOTDIR=.. +CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib COMPFLAGS=-warn-error A $(INCLUDES) LINKFLAGS=-linkall -I $(UNIXDIR) CAMLYACC=../boot/ocamlyacc @@ -21,6 +22,8 @@ CAMLLEX=../boot/ocamlrun ../boot/ocamllex CAMLDEP=../boot/ocamlrun ../tools/ocamldep DEPFLAGS=$(INCLUDES) +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) + INCLUDES=\ -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \ -I $(UNIXDIR) @@ -83,7 +86,7 @@ ocamldebug$(EXE): $(OBJS) $(OTHEROBJS) $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS) install: - cp ocamldebug$(EXE) $(BINDIR)/ocamldebug$(EXE) + cp ocamldebug$(EXE) $(INSTALL_BINDIR)/ocamldebug$(EXE) clean:: rm -f ocamldebug$(EXE) diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml index b2d472a7dc..1ebbd1e821 100644 --- a/debugger/program_loading.ml +++ b/debugger/program_loading.ml @@ -41,10 +41,35 @@ let get_unix_environment () = String.concat "" (List.map f !Debugger_config.environment) ;; +(* Notes: + 1. This quoting is not the same as [Filename.quote] because the "set" + command is a shell built-in and its quoting rules are different + from regular commands. + 2. Microsoft's documentation omits the double-quote from the list + of characters that need quoting, but that is a mistake (unquoted + quotes are included in the value, but they alter the quoting of + characters between them). + Reference: http://msdn.microsoft.com/en-us/library/bb490954.aspx + *) +let quote_for_windows_shell s = + let b = Buffer.create (20 + String.length s) in + for i = 0 to String.length s - 1 do + begin match s.[i] with + | '<' | '>' | '|' | '&' | '^' | '\"' -> + Buffer.add_char b '^'; + | _ -> () + end; + Buffer.add_char b s.[i]; + done; + Buffer.contents b +;; + (* Returns a command line prefix to set environment for the debuggee *) let get_win32_environment () = (* Note: no space before the & or Windows will add it to the value *) - let f (vname, vvalue) = Printf.sprintf "set %s=%s&" vname vvalue in + let f (vname, vvalue) = + Printf.sprintf "set %s=%s&" vname (quote_for_windows_shell vvalue) + in String.concat "" (List.map f !Debugger_config.environment) (* A generic function for launching the program *) diff --git a/debugger/program_management.ml b/debugger/program_management.ml index c7438b3981..1e29b138f8 100644 --- a/debugger/program_management.ml +++ b/debugger/program_management.ml @@ -124,6 +124,8 @@ let initialize_loading () = raise Toplevel; end; Symbols.read_symbols !program_name; + Config.load_path := !Config.load_path @ !Symbols.program_source_dirs; + Envaux.reset_cache (); if !debug_loading then prerr_endline "Opening a socket..."; open_connection !socket_name diff --git a/debugger/symbols.ml b/debugger/symbols.ml index 331d5bbdbe..1be7253328 100644 --- a/debugger/symbols.ml +++ b/debugger/symbols.ml @@ -17,9 +17,14 @@ open Instruct open Debugger_config (* Toplevel *) open Program_loading +module StringSet = Set.Make(String) + let modules = ref ([] : string list) +let program_source_dirs = + ref ([] : string list) + let events = ref ([] : debug_event list) let events_by_pc = @@ -52,13 +57,16 @@ let read_symbols' bytecode_file = raise Toplevel end; let num_eventlists = input_binary_int ic in + let dirs = ref StringSet.empty in let eventlists = ref [] in for i = 1 to num_eventlists do let orig = input_binary_int ic in let evl = (input_value ic : debug_event list) in (* Relocate events in event list *) List.iter (relocate_event orig) evl; - eventlists := evl :: !eventlists + eventlists := evl :: !eventlists; + dirs := + List.fold_left (fun s e -> StringSet.add e s) !dirs (input_value ic) done; begin try ignore (Bytesections.seek_section ic "CODE") @@ -68,12 +76,13 @@ let read_symbols' bytecode_file = set_launching_function (List.assoc "manual" loading_modes) end; close_in_noerr ic; - !eventlists + !eventlists, !dirs let read_symbols bytecode_file = - let all_events = read_symbols' bytecode_file in + let all_events, all_dirs = read_symbols' bytecode_file in modules := []; events := []; + program_source_dirs := StringSet.elements all_dirs; Hashtbl.clear events_by_pc; Hashtbl.clear events_by_module; Hashtbl.clear all_events_by_module; diff --git a/debugger/symbols.mli b/debugger/symbols.mli index 980892e048..883b81aa3e 100644 --- a/debugger/symbols.mli +++ b/debugger/symbols.mli @@ -14,6 +14,10 @@ (* Modules used by the program. *) val modules : string list ref +(* Absolute directories containing source code on machine where source was + * compiled *) +val program_source_dirs : string list ref + (* Read debugging info from executable file *) val read_symbols : string -> unit diff --git a/driver/compmisc.mli b/driver/compmisc.mli index 4c8cb0647b..032e9fe4aa 100644 --- a/driver/compmisc.mli +++ b/driver/compmisc.mli @@ -12,4 +12,3 @@ val init_path : bool -> unit val initial_env : unit -> Env.t - diff --git a/driver/main_args.ml b/driver/main_args.ml index aba306b54a..ec97d6c983 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -724,6 +724,7 @@ struct mk_warn_error F._warn_error; mk_warn_help F._warn_help; mk_where F._where; + mk__ F.anonymous; mk_nopervasives F._nopervasives; mk_use_prims F._use_prims; @@ -733,8 +734,6 @@ struct mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dinstr F._dinstr; - - mk__ F.anonymous; ] end;; @@ -765,6 +764,7 @@ struct mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; + mk__ F.anonymous; mk_dsource F._dsource; mk_dparsetree F._dparsetree; @@ -772,8 +772,6 @@ struct mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dinstr F._dinstr; - - mk__ F.anonymous; ] end;; @@ -832,6 +830,7 @@ struct mk_warn_error F._warn_error; mk_warn_help F._warn_help; mk_where F._where; + mk__ F.anonymous; mk_nopervasives F._nopervasives; mk_dsource F._dsource; @@ -853,8 +852,6 @@ struct mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; mk_dstartup F._dstartup; - - mk__ F.anonymous; ] end;; @@ -887,6 +884,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; + mk__ F.anonymous; mk_dsource F._dsource; mk_dparsetree F._dparsetree; @@ -906,7 +904,5 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; mk_dstartup F._dstartup; - - mk__ F.anonymous; ] end;; diff --git a/lex/Makefile b/lex/Makefile index f54de0020b..e3cbd320be 100644 --- a/lex/Makefile +++ b/lex/Makefile @@ -34,7 +34,7 @@ ocamllex.opt: $(OBJS:.cmo=.cmx) clean:: rm -f ocamllex ocamllex.opt - rm -f *.cmo *.cmi *.cmx *.o *~ + rm -f *.cmo *.cmi *.cmx *.cmt *.cmti *.o *~ parser.ml parser.mli: parser.mly $(CAMLYACC) $(YACCFLAGS) parser.mly diff --git a/lex/parser.mly b/lex/parser.mly index f0742e38e4..459b787077 100644 --- a/lex/parser.mly +++ b/lex/parser.mly @@ -65,7 +65,8 @@ let as_cset = function %% lexer_definition: - header named_regexps refill_handler Trule definition other_definitions header Tend + header named_regexps refill_handler Trule definition other_definitions + header Tend { {header = $1; refill_handler = $3; entrypoints = $5 :: List.rev $6; diff --git a/man/Makefile b/man/Makefile index 916ea24a81..c1c2df3752 100644 --- a/man/Makefile +++ b/man/Makefile @@ -12,10 +12,13 @@ include ../config/Makefile -DIR=$(MANDIR)/man$(MANEXT) +INSTALL_DIR=$(DESTDIR)$(MANDIR)/man$(MANEXT) install: - for i in *.m; do cp $$i $(DIR)/`basename $$i .m`.$(MANEXT); done - echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' > $(DIR)/ocamlc.opt.$(MANEXT) - echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' > $(DIR)/ocamlopt.opt.$(MANEXT) - echo '.so man$(MANEXT)/ocamlcp.$(MANEXT)' > $(DIR)/ocamloptp.$(MANEXT) + for i in *.m; do cp $$i $(INSTALL_DIR)/`basename $$i .m`.$(MANEXT); done + echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' \ + > $(INSTALL_DIR)/ocamlc.opt.$(MANEXT) + echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' \ + > $(INSTALL_DIR)/ocamlopt.opt.$(MANEXT) + echo '.so man$(MANEXT)/ocamlcp.$(MANEXT)' \ + > $(INSTALL_DIR)/ocamloptp.$(MANEXT) diff --git a/man/ocamlopt.m b/man/ocamlopt.m index d00cbf99d2..766d2a4c6b 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -631,6 +631,41 @@ Generate SPARC version 9 code. The default is to generate code for SPARC version 7, which runs on all SPARC processors. +.SH OPTIONS FOR THE ARM ARCHITECTURE +The ARM code generator supports the following additional options: +.TP +.B \-farch=armv4|armv5|armv5te|armv6|armv6t2|armv7 +Select the ARM target architecture +.TP +.B \-ffpu=soft|vfpv2|vfpv3\-d16|vfpv3 +Select the floating-point hardware +.TP +.B \-fPIC +Generate position-independent machine code. +.TP +.B \-fno\-PIC +Generate position-dependent machine code. This is the default. +.TP +.B \-fthumb +Enable Thumb/Thumb-2 code generation +.TP +.B \-fno\-thumb +Disable Thumb/Thumb-2 code generation +.P +The default values for target architecture, floating-point hardware +and thumb usage were selected at configure-time when building +.BR ocamlopt +itself. This configuration can be inspected using +.BR ocamlopt +.BR \-config . +Target architecture depends on the "model" setting, while +floating-point hardware and thumb support are determined from the ABI +setting in "system" ( +.BR linux_eabi +or +.BR linux_eabihf +). + .SH SEE ALSO .BR ocamlc (1). .br diff --git a/ocamlbuild/.depend b/ocamlbuild/.depend index 5e0c7e6607..c983ee1288 100644 --- a/ocamlbuild/.depend +++ b/ocamlbuild/.depend @@ -27,10 +27,10 @@ ocaml_tools.cmi : tags.cmi rule.cmi pathname.cmi command.cmi ocaml_utils.cmi : tags.cmi pathname.cmi command.cmi ocamlbuild.cmi : ocamlbuild_executor.cmi : -ocamlbuild_plugin.cmi : -ocamlbuild_unix_plugin.cmi : +ocamlbuild_plugin.cmi : ocamlbuild_pack.cmi +ocamlbuild_unix_plugin.cmi : ocamlbuild_pack.cmi ocamlbuild_where.cmi : -ocamlbuildlight.cmi : +ocamlbuildlight.cmi : ocamlbuild_pack.cmi options.cmi : slurp.cmi signatures.cmi command.cmi param_tags.cmi : tags.cmi loc.cmi pathname.cmi : signatures.cmi @@ -141,8 +141,9 @@ ocamlbuild_config.cmo : ocamlbuild_config.cmx : ocamlbuild_executor.cmo : ocamlbuild_executor.cmi ocamlbuild_executor.cmx : ocamlbuild_executor.cmi -ocamlbuild_plugin.cmo : ocamlbuild_plugin.cmi -ocamlbuild_plugin.cmx : ocamlbuild_plugin.cmi +ocamlbuild_pack.cmo : ocamlbuild_pack.cmi +ocamlbuild_plugin.cmo : ocamlbuild_plugin.cmi ocamlbuild_pack.cmo +ocamlbuild_plugin.cmx : ocamlbuild_plugin.cmi ocamlbuild_pack.cmx ocamlbuild_unix_plugin.cmo : ocamlbuild_executor.cmi my_unix.cmi my_std.cmi \ exit_codes.cmi ocamlbuild_unix_plugin.cmi ocamlbuild_unix_plugin.cmx : ocamlbuild_executor.cmx my_unix.cmx my_std.cmx \ diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile index ec3b999ea6..54d6283246 100644 --- a/ocamlbuild/Makefile +++ b/ocamlbuild/Makefile @@ -12,12 +12,13 @@ include ../config/Makefile -OCAMLRUN = ../boot/ocamlrun -OCAMLC = ../ocamlcomp.sh -OCAMLOPT = ../ocamlcompopt.sh -OCAMLDEP = $(OCAMLRUN) ../tools/ocamldep -OCAMLLEX = $(OCAMLRUN) ../boot/ocamllex -CP = cp +ROOTDIR = .. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex +CP = cp COMPFLAGS= -warn-error A -w L -w R -w Z -I ../otherlibs/$(UNIXLIB) LINKFLAGS= -I ../otherlibs/$(UNIXLIB) @@ -85,6 +86,9 @@ INSTALL_LIB_OPT=\ ocamlbuild_pack.cmx \ $(EXTRA_CMO:.cmo=.cmx) $(EXTRA_CMO:.cmo=.$(O)) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)/ocamlbuild +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) + all: ocamlbuild.byte ocamlbuildlib.cma # ocamlbuildlight.byte ocamlbuildlightlib.cma allopt: ocamlbuild.native ocamlbuildlib.cmxa @@ -157,19 +161,19 @@ beforedepend:: glob_lexer.ml # Installation install: - $(CP) ocamlbuild.byte $(BINDIR)/ocamlbuild$(EXE) - $(CP) ocamlbuild.byte $(BINDIR)/ocamlbuild.byte$(EXE) - mkdir -p $(LIBDIR)/ocamlbuild - $(CP) $(INSTALL_LIB) $(LIBDIR)/ocamlbuild/ + $(CP) ocamlbuild.byte $(INSTALL_BINDIR)/ocamlbuild$(EXE) + $(CP) ocamlbuild.byte $(INSTALL_BINDIR)/ocamlbuild.byte$(EXE) + mkdir -p $(INSTALL_LIBDIR) + $(CP) $(INSTALL_LIB) $(INSTALL_LIBDIR)/ installopt: if test -f ocamlbuild.native; then $(MAKE) installopt_really; fi installopt_really: - $(CP) ocamlbuild.native $(BINDIR)/ocamlbuild$(EXE) - $(CP) ocamlbuild.native $(BINDIR)/ocamlbuild.native$(EXE) - mkdir -p $(LIBDIR)/ocamlbuild - $(CP) $(INSTALL_LIB_OPT) $(LIBDIR)/ocamlbuild/ + $(CP) ocamlbuild.native $(INSTALL_BINDIR)/ocamlbuild$(EXE) + $(CP) ocamlbuild.native $(INSTALL_BINDIR)/ocamlbuild.native$(EXE) + mkdir -p $(INSTALL_LIBDIR) + $(CP) $(INSTALL_LIB_OPT) $(INSTALL_LIBDIR)/ # The generic rules @@ -195,5 +199,5 @@ depend: beforedepend include .depend -.PHONY: all allopt clean beforedepend +.PHONY: all allopt clean beforedepend .PHONY: install installopt installopt_really depend diff --git a/ocamlbuild/Makefile.noboot b/ocamlbuild/Makefile.noboot index 0679e0ccd7..de914e15ec 100644 --- a/ocamlbuild/Makefile.noboot +++ b/ocamlbuild/Makefile.noboot @@ -17,11 +17,13 @@ include ../config/Makefile # Various commands and dir ########################## -CAMLRUN = ../boot/ocamlrun -OCAMLC = ../ocamlcomp.sh -OCAMLOPT = ../ocamlcompopt.sh -OCAMLDEP = $(CAMLRUN) ../tools/ocamldep -OCAMLLEX = $(CAMLRUN) ../boot/ocamllex + +ROOTDIR = .. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex OCAMLLIB = $(LIBDIR) OCAMLBIN = $(BINDIR) @@ -35,10 +37,9 @@ OCAMLBUILD_LIBCMA=ocamlbuildlib.cma OCAMLBUILD_LIBCMI=ocamlbuildlib.cmi OCAMLBUILD_LIBCMXA=ocamlbuild.cmxa OCAMLBUILD_LIBA=ocamlbuild.$(A) -INSTALL_LIBDIR=$(OCAMLLIB)/ocamlbuild +INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/ocamlbuild INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom -INSTALL_BINDIR=$(OCAMLBIN) -INSTALL_MANODIR=$(MANDIR)/man3 +INSTALL_BINDIR=$(DESTDIR)$(OCAMLBIN) INSTALL_MLIS= INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 6de33180de..f6d7b15ab2 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -14,14 +14,15 @@ include ../config/Makefile # Various commands and dir ########################## -CAMLRUN=../boot/ocamlrun -OCAMLC = ../ocamlcomp.sh -OCAMLOPT = ../ocamlcompopt.sh -OCAMLDEP = $(CAMLRUN) ../tools/ocamldep -OCAMLLEX = $(CAMLRUN) ../boot/ocamllex -OCAMLYACC= ../boot/ocamlyacc -OCAMLLIB = $(LIBDIR) -OCAMLBIN = $(BINDIR) +ROOTDIR = .. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex +OCAMLYACC = $(ROOTDIR)/yacc/ocamlyacc +OCAMLLIB = $(LIBDIR) +OCAMLBIN = $(BINDIR) OCAMLPP=-pp './remove_DEBUG' @@ -36,10 +37,11 @@ OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi OCAMLDOC_LIBCMXA=odoc_info.cmxa OCAMLDOC_LIBA=odoc_info.$(A) -INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc +INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/ocamldoc INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom -INSTALL_BINDIR=$(OCAMLBIN) -INSTALL_MANODIR=$(MANDIR)/man3 +INSTALL_BINDIR=$(DESTDIR)$(OCAMLBIN) +#MANO: man ocamldoc +INSTALL_MANODIR=$(DESTDIR)$(MANDIR)/man3 INSTALL_MLIS=odoc_info.mli INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index ff4b3fdc24..158fa7db34 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -14,12 +14,13 @@ include ../config/Makefile # Various commands and dir ########################## -CAMLRUN=../boot/ocamlrun -OCAMLC = ../ocamlcomp.sh -OCAMLOPT = ../ocamlcompopt.sh -OCAMLDEP = $(CAMLRUN) ../tools/ocamldep -OCAMLLEX = $(CAMLRUN) ../boot/ocamllex -OCAMLYACC= ../boot/ocamlyacc +ROOTDIR = .. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex +OCAMLYACC = $(ROOTDIR)/yacc/ocamlyacc OCAMLLIB = $(LIBDIR) OCAMLBIN = $(BINDIR) @@ -36,9 +37,9 @@ OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi OCAMLDOC_LIBCMXA=odoc_info.cmxa OCAMLDOC_LIBA=odoc_info.$(A) -INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc +INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/ocamldoc INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom -INSTALL_BINDIR=$(OCAMLBIN) +INSTALL_BINDIR=$(DESTDIR)$(OCAMLBIN) INSTALL_MLIS=odoc_info.mli INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) diff --git a/otherlibs/Makefile b/otherlibs/Makefile index 6c3e58aa65..397497dd55 100644 --- a/otherlibs/Makefile +++ b/otherlibs/Makefile @@ -13,8 +13,9 @@ # Common Makefile for otherlibs on the Unix ports -CAMLC=$(ROOTDIR)/ocamlcomp.sh -CAMLOPT=$(ROOTDIR)/ocamlcompopt.sh +CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +CAMLOPT=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlopt -nostdlib \ + -I $(ROOTDIR)/stdlib CFLAGS=-I$(ROOTDIR)/byterun -O $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) include ../Makefile.shared diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt index aafb4217cb..6d16f8d273 100644 --- a/otherlibs/Makefile.nt +++ b/otherlibs/Makefile.nt @@ -13,10 +13,9 @@ # Common Makefile for otherlibs on the Win32/MinGW ports -CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib -w s -CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib -w s -CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) +include ../Makefile + +# The Unix version now works fine under Windows -include ../Makefile.shared # Note .. is the current directory (this makefile is included from # a subdirectory) diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared index 751a15870d..6c2fc5d67a 100644 --- a/otherlibs/Makefile.shared +++ b/otherlibs/Makefile.shared @@ -56,18 +56,21 @@ $(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A) lib$(CLIBNAME).$(A): $(COBJS) $(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) + install:: if test -f dll$(CLIBNAME)$(EXT_DLL); then \ - cp dll$(CLIBNAME)$(EXT_DLL) $(STUBLIBDIR)/; fi - cp lib$(CLIBNAME).$(A) $(LIBDIR)/ - cd $(LIBDIR); $(RANLIB) lib$(CLIBNAME).$(A) - cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(LIBDIR)/ - if test -n "$(HEADERS)"; then cp $(HEADERS) $(LIBDIR)/caml/; fi + cp dll$(CLIBNAME)$(EXT_DLL) $(INSTALL_STUBLIBDIR)/; fi + cp lib$(CLIBNAME).$(A) $(INSTALL_LIBDIR)/ + cd $(INSTALL_LIBDIR); $(RANLIB) lib$(CLIBNAME).$(A) + cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(INSTALL_LIBDIR)/ + if test -n "$(HEADERS)"; then cp $(HEADERS) $(INSTALL_LIBDIR)/caml/; fi installopt: - cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(LIBDIR)/ - cd $(LIBDIR); $(RANLIB) $(LIBNAME).a - if test -f $(LIBNAME).cmxs; then cp $(LIBNAME).cmxs $(LIBDIR)/; fi + cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALL_LIBDIR)/ + cd $(INSTALL_LIBDIR); $(RANLIB) $(LIBNAME).a + if test -f $(LIBNAME).cmxs; then cp $(LIBNAME).cmxs $(INSTALL_LIBDIR)/; fi partialclean: rm -f *.cm* diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index 058c25904a..b3016a7171 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -108,7 +108,7 @@ type ('a, 'b) kind = let zero : type a b. (a, b) kind -> a = function | Float32 -> 0.0 | Complex32 -> Complex.zero | Float64 -> 0.0 | Complex64 -> Complex.zero - | Int8_signed -> 0 | Int8_unsigned -> 0 + | Int8_signed -> 0 | Int8_unsigned -> 0 | Int16_signed -> 0 | Int16_unsigned -> 0 | Int32 -> 0l | Int64 -> 0L | Int -> 0 | Nativeint -> 0n diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 67b160aa49..15b01921bb 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -15,8 +15,11 @@ include ../../config/Makefile -CAMLC=../../boot/ocamlrun ../../ocamlc -CAMLOPT=../../ocamlcompopt.sh +ROOTDIR = ../.. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib + INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp COMPFLAGS=-w +33..39 -warn-error A -bin-annot -I ../../stdlib $(INCLUDES) @@ -47,38 +50,40 @@ all: dynlink.cma extract_crc allopt: dynlink.cmxa dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma \ + $(OCAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma \ $(OBJS) dynlink.cmxa: $(NATOBJS) - $(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa \ + $(OCAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa \ $(NATOBJS) dynlinkaux.cmo: $(COMPILEROBJS) - $(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) + $(OCAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) dynlinkaux.cmi: dynlinkaux.cmo dynlink.cmx: dynlink.cmi natdynlink.ml cp natdynlink.ml dynlink.mlopt - $(CAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt + $(OCAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt rm -f dynlink.mlopt extract_crc: dynlink.cma extract_crc.cmo - $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo + $(OCAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo + +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) install: - cp dynlink.cmi dynlink.cma dynlink.mli $(LIBDIR) - cp extract_crc $(LIBDIR)/extract_crc$(EXE) + cp dynlink.cmi dynlink.cma dynlink.mli $(INSTALL_LIBDIR) + cp extract_crc $(INSTALL_LIBDIR)/extract_crc$(EXE) installopt: if $(NATDYNLINK); then \ - cp $(NATOBJS) dynlink.cmxa dynlink.$(A) $(LIBDIR) && \ - cd $(LIBDIR) && $(RANLIB) dynlink.$(A); \ + cp $(NATOBJS) dynlink.cmxa dynlink.$(A) $(INSTALL_LIBDIR) && \ + cd $(INSTALL_LIBDIR) && $(RANLIB) dynlink.$(A); \ fi partialclean: - rm -f extract_crc *.cm[ioax] *.cmxa + rm -f extract_crc *.cm[ioaxt] *.cmti *.cmxa clean: partialclean rm -f *.$(A) *.$(O) *.so *.dll dynlink.mlopt @@ -86,13 +91,13 @@ clean: partialclean .SUFFIXES: .ml .mli .cmo .cmi .cmx .mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< + $(OCAMLC) -c $(COMPFLAGS) $< .ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< + $(OCAMLC) -c $(COMPFLAGS) $< .ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< + $(OCAMLOPT) -c $(COMPFLAGS) $< depend: diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index 3da02c2601..a34bd4b879 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -13,8 +13,11 @@ include ../../config/Makefile -CAMLC=../../ocamlcomp.sh -I ../unix -CAMLOPT=../../ocamlcompopt.sh -I ../unix +ROOTDIR=../.. +CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib \ + -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix +CAMLOPT=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlopt -nostdlib \ + -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib COMPFLAGS=-w +33..39 -warn-error A -g -bin-annot @@ -69,21 +72,27 @@ partialclean: clean: partialclean rm -f *.o *.a *.so +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) + install: - if test -f dllthreads.so; then cp dllthreads.so $(STUBLIBDIR)/dllthreads.so; fi - cp libthreads.a $(LIBDIR)/libthreads.a - cd $(LIBDIR); $(RANLIB) libthreads.a - if test -d $(LIBDIR)/threads; then :; else mkdir $(LIBDIR)/threads; fi - cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(LIBDIR)/threads - rm -f $(LIBDIR)/threads/stdlib.cma - cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR) - cp threads.h $(LIBDIR)/caml/threads.h + if test -f dllthreads.so; then \ + cp dllthreads.so $(INSTALL_STUBLIBDIR)/dllthreads.so; fi + cp libthreads.a $(INSTALL_LIBDIR)/libthreads.a + cd $(INSTALL_LIBDIR); $(RANLIB) libthreads.a + if test -d $(INSTALL_LIBDIR)/threads; then :; \ + else mkdir $(INSTALL_LIBDIR)/threads; fi + cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(INSTALL_LIBDIR)/threads + rm -f $(INSTALL_LIBDIR)/threads/stdlib.cma + cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \ + $(INSTALL_LIBDIR) + cp threads.h $(INSTALL_LIBDIR)/caml/threads.h installopt: - cp libthreadsnat.a $(LIBDIR)/libthreadsnat.a - cd $(LIBDIR); $(RANLIB) libthreadsnat.a - cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.a $(LIBDIR)/threads - cd $(LIBDIR)/threads; $(RANLIB) threads.a + cp libthreadsnat.a $(INSTALL_LIBDIR)/libthreadsnat.a + cd $(INSTALL_LIBDIR); $(RANLIB) libthreadsnat.a + cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.a $(INSTALL_LIBDIR)/threads + cd $(INSTALL_LIBDIR)/threads; $(RANLIB) threads.a .SUFFIXES: .ml .mli .cmo .cmi .cmx diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt index 225146cced..341176146f 100644 --- a/otherlibs/systhreads/Makefile.nt +++ b/otherlibs/systhreads/Makefile.nt @@ -70,18 +70,21 @@ partialclean: clean: partialclean rm -f *.dll *.$(A) *.$(O) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) + install: - cp dllthreads.dll $(STUBLIBDIR)/dllthreads.dll - cp libthreads.$(A) $(LIBDIR)/libthreads.$(A) - mkdir -p $(LIBDIR)/threads - cp $(CMIFILES) threads.cma $(LIBDIR)/threads - rm -f $(LIBDIR)/threads/stdlib.cma - cp threads.h $(LIBDIR)/caml/threads.h + cp dllthreads.dll $(INSTALL_STUBLIBDIR)/dllthreads.dll + cp libthreads.$(A) $(INSTALL_LIBDIR)/libthreads.$(A) + mkdir -p $(INSTALL_LIBDIR)/threads + cp $(CMIFILES) threads.cma $(INSTALL_LIBDIR)/threads + rm -f $(INSTALL_LIBDIR)/threads/stdlib.cma + cp threads.h $(INSTALL_LIBDIR)/caml/threads.h installopt: - cp libthreadsnat.$(A) $(LIBDIR)/libthreadsnat.$(A) - cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(LIBDIR)/threads - cp threads.cmxs $(LIBDIR)/threads + cp libthreadsnat.$(A) $(INSTALL_LIBDIR)/libthreadsnat.$(A) + cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(INSTALL_LIBDIR)/threads + cp threads.cmxs $(INSTALL_LIBDIR)/threads .SUFFIXES: .ml .mli .cmo .cmi .cmx diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 3aa6c2acf8..5c4be281da 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -15,7 +15,9 @@ include ../../config/Makefile CC=$(BYTECC) CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g -CAMLC=../../ocamlcomp.sh -I ../unix +ROOTDIR=../.. +CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib \ + -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib COMPFLAGS=-w +33..39 -warn-error A -bin-annot @@ -95,15 +97,18 @@ clean: partialclean rm -f libvmthreads.a dllvmthreads.so *.o rm -f pervasives.mli marshal.mli unix.mli +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) + install: - if test -f dllvmthreads.so; then cp dllvmthreads.so $(STUBLIBDIR)/.; fi - mkdir -p $(LIBDIR)/vmthreads - cp libvmthreads.a $(LIBDIR)/vmthreads/libvmthreads.a - cd $(LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a + if test -f dllvmthreads.so; then cp dllvmthreads.so $(INSTALL_STUBLIBDIR)/.; fi + mkdir -p $(INSTALL_LIBDIR)/vmthreads + cp libvmthreads.a $(INSTALL_LIBDIR)/vmthreads/libvmthreads.a + cd $(INSTALL_LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi \ - threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads + threads.cma stdlib.cma unix.cma $(INSTALL_LIBDIR)/vmthreads cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \ - $(LIBDIR)/vmthreads + $(INSTALL_LIBDIR)/vmthreads installopt: @@ -115,9 +120,6 @@ installopt: .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - depend: gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 402e01b87c..7992c68d2d 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -40,6 +40,20 @@ exception Exit external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(* Debugging *) + +external __LOC__ : string = "%loc_LOC" +external __FILE__ : string = "%loc_FILE" +external __LINE__ : int = "%loc_LINE" +external __MODULE__ : string = "%loc_MODULE" +external __POS__ : string * int * int * int = "%loc_POS" + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +external __FILE_OF__ : 'a -> string * 'a = "%loc_FILE" +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +external __MODULE_OF__ : 'a -> string * 'a = "%loc_MODULE" +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" + (* Comparisons *) external (=) : 'a -> 'a -> bool = "%equal" diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index d8a15753eb..efc3fe6fc4 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -799,8 +799,8 @@ val setitimer : its previous status. The [s] argument is interpreted as follows: [s.it_value], if nonzero, is the time to the next timer expiration; [s.it_interval], if nonzero, specifies a value to - be used in reloading it_value when the timer expires. - Setting [s.it_value] to zero disable the timer. + be used in reloading [it_value] when the timer expires. + Setting [s.it_value] to zero disables the timer. Setting [s.it_interval] to zero causes the timer to be disabled after its next expiration. *) diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli index 4dc411b0b5..53e16b1d76 100644 --- a/otherlibs/unix/unixLabels.mli +++ b/otherlibs/unix/unixLabels.mli @@ -236,10 +236,14 @@ type open_flag = Unix.open_flag = | O_TRUNC (** Truncate to 0 length if existing *) | O_EXCL (** Fail if existing *) | O_NOCTTY (** Don't make this dev a controlling tty *) - | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) - | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) - | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) - | O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *) + | O_DSYNC (** Writes complete as `Synchronised I/O data + integrity completion' *) + | O_SYNC (** Writes complete as `Synchronised I/O file + integrity completion' *) + | O_RSYNC (** Reads complete as writes (depending + on O_SYNC/O_DSYNC) *) + | O_SHARE_DELETE (** Windows only: allow the file to be deleted + while still open *) | O_CLOEXEC (** Set the close-on-exec flag on the descriptor returned by {!openfile} *) (** The flags to {!UnixLabels.openfile}. *) @@ -772,9 +776,11 @@ val utimes : string -> access:float -> modif:float -> unit type interval_timer = Unix.interval_timer = ITIMER_REAL - (** decrements in real time, and sends the signal [SIGALRM] when expired.*) + (** decrements in real time, and sends the signal [SIGALRM] when + expired.*) | ITIMER_VIRTUAL - (** decrements in process virtual time, and sends [SIGVTALRM] when expired. *) + (** decrements in process virtual time, and sends [SIGVTALRM] when + expired. *) | ITIMER_PROF (** (for profiling) decrements both when the process is running and when the system is running on behalf of the @@ -1031,12 +1037,12 @@ type socket_bool_option = ([true]/[false]) value. *) type socket_int_option = - SO_SNDBUF (** Size of send buffer *) - | SO_RCVBUF (** Size of received buffer *) - | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) - | SO_TYPE (** Report the socket type *) - | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) - | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) + SO_SNDBUF (** Size of send buffer *) + | SO_RCVBUF (** Size of received buffer *) + | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) + | SO_TYPE (** Report the socket type *) + | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) + | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) (** The socket options that can be consulted with {!UnixLabels.getsockopt_int} and modified with {!UnixLabels.setsockopt_int}. These options have an integer value. *) @@ -1071,17 +1077,21 @@ val setsockopt_int : file_descr -> socket_int_option -> int -> unit (** Same as {!Unix.setsockopt} for an integer-valued socket option. *) val getsockopt_optint : file_descr -> socket_optint_option -> int option -(** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) +(** Same as {!Unix.getsockopt} for a socket option whose value is + an [int option]. *) val setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit -(** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) +(** Same as {!Unix.setsockopt} for a socket option whose value is + an [int option]. *) val getsockopt_float : file_descr -> socket_float_option -> float -(** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) +(** Same as {!Unix.getsockopt} for a socket option whose value is a + floating-point number. *) val setsockopt_float : file_descr -> socket_float_option -> float -> unit -(** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) +(** Same as {!Unix.setsockopt} for a socket option whose value is a + floating-point number. *) val getsockopt_error : file_descr -> error option (** Return the error condition associated with the given socket, diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index 5e62da5d39..4bdae36a1e 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -99,7 +99,7 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM // End application case WM_DESTROY: ResetForClose(hwnd); - gr_check_open(); + gr_check_open(); break; } caml_gr_handle_event(msg, wParam, lParam); diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c index f2745fb197..32532553fc 100644 --- a/otherlibs/win32unix/sendrecv.c +++ b/otherlibs/win32unix/sendrecv.c @@ -22,7 +22,8 @@ static int msg_flag_table[] = { MSG_OOB, MSG_DONTROUTE, MSG_PEEK }; -CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) +CAMLprim value unix_recv(value sock, value buff, value ofs, value len, + value flags) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); @@ -47,7 +48,8 @@ CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value fla return Val_int(ret); } -CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) +CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, + value flags) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); @@ -81,7 +83,8 @@ CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value return res; } -CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) +CAMLprim value unix_send(value sock, value buff, value ofs, value len, + value flags) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); @@ -104,7 +107,8 @@ CAMLprim value unix_send(value sock, value buff, value ofs, value len, value fla return Val_int(ret); } -value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) +value unix_sendto_native(value sock, value buff, value ofs, value len, + value flags, value dest) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index ec70235f0b..c6873aee0e 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -29,7 +29,8 @@ let with_default_loc l f = with exn -> default_loc := old; raise exn module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any @@ -52,7 +53,8 @@ module Typ = struct end module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any @@ -74,7 +76,8 @@ module Pat = struct end module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) @@ -121,7 +124,8 @@ module Exp = struct end module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) @@ -134,12 +138,14 @@ module Mty = struct end module Mod = struct -let mk ?(loc = !default_loc) ?(attrs = []) d = {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} +let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) + let functor_ ?loc ?attrs arg arg_ty body = + mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) @@ -171,7 +177,8 @@ module Str = struct let primitive ?loc a = mk ?loc (Pstr_primitive a) let type_ ?loc a = mk ?loc (Pstr_type a) let exception_ ?loc a = mk ?loc (Pstr_exception a) - let exn_rebind ?loc ?(attrs = []) a b = mk ?loc (Pstr_exn_rebind (a, b, attrs)) + let exn_rebind ?loc ?(attrs = []) a b = + mk ?loc (Pstr_exn_rebind (a, b, attrs)) let module_ ?loc a = mk ?loc (Pstr_module a) let rec_module ?loc a = mk ?loc (Pstr_recmodule a) let modtype ?loc a = mk ?loc (Pstr_modtype a) @@ -303,7 +310,8 @@ module Vb = struct end module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(virt = Concrete) ?(params = []) name expr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(virt = Concrete) ?(params = []) + name expr = { pci_virt = virt; pci_params = params; @@ -398,7 +406,8 @@ module Convenience = struct let pvar s = Pat.var (mkloc s !default_loc) let pconstr s args = Pat.construct (lid s) (may_tuple Pat.tuple args) - let precord ?(closed = Open) l = Pat.record (List.map (fun (s, e) -> (lid s, e)) l) closed + let precord ?(closed = Open) l = + Pat.record (List.map (fun (s, e) -> (lid s, e)) l) closed let pnil () = pconstr "[]" [] let pcons hd tl = pconstr "::" [hd; tl] let punit () = pconstr "()" [] diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 70db004045..e2bc166bdf 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -38,15 +38,19 @@ module Typ : val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> core_type -> core_type + val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> core_type + -> core_type val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> (string * core_type) list -> closed_flag -> core_type + val object_: ?loc:loc -> ?attrs:attrs -> (string * core_type) list + -> closed_flag -> core_type val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag -> label list option -> core_type + val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag + -> label list option -> core_type val poly: ?loc:loc -> ?attrs:attrs -> string list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list -> core_type + val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list + -> core_type val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type val force_poly: core_type -> core_type @@ -66,7 +70,8 @@ module Pat: val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag -> pattern + val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag + -> pattern val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern @@ -84,14 +89,19 @@ module Exp: val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> expression -> expression + val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list + -> expression -> expression + val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern + -> expression -> expression val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression -> (label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val apply: ?loc:loc -> ?attrs:attrs -> expression + -> (label * expression) list -> expression + val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list + -> expression val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression + val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option + -> expression val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option -> expression val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list -> expression option -> expression val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 246319e4d9..2706e94e62 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -32,9 +32,11 @@ type mapper = { class_signature: mapper -> class_signature -> class_signature; class_structure: mapper -> class_structure -> class_structure; class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration -> class_type_declaration; + class_type_declaration: mapper -> class_type_declaration + -> class_type_declaration; class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration -> constructor_declaration; + constructor_declaration: mapper -> constructor_declaration + -> constructor_declaration; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; label_declaration: mapper -> label_declaration -> label_declaration; @@ -43,7 +45,8 @@ type mapper = { module_declaration: mapper -> module_declaration -> module_declaration; module_expr: mapper -> module_expr -> module_expr; module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration -> module_type_declaration; + module_type_declaration: mapper -> module_type_declaration + -> module_type_declaration; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; signature: mapper -> signature -> signature; @@ -108,7 +111,8 @@ module T = struct Type.mk (map_loc sub ptype_name) ~params:(List.map (map_fst (map_opt (map_loc sub))) ptype_params) ~priv:ptype_private - ~cstrs:(List.map (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ~cstrs:(List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) ptype_cstrs) ~kind:(sub.type_kind sub ptype_kind) ?manifest:(map_opt (sub.typ sub) ptype_manifest) @@ -225,7 +229,8 @@ module M = struct | Pmod_apply (m1, m2) -> apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) + constraint_ ~loc ~attrs (sub.module_expr sub m) + (sub.module_type sub mty) | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) @@ -298,7 +303,8 @@ module E = struct (map_opt (sub.expr sub) e3) | Pexp_sequence (e1, e2) -> sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) | Pexp_for (p, e1, e2, d, e3) -> for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d (sub.expr sub e3) @@ -347,8 +353,8 @@ module P = struct construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) - cf + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) | Ppat_constraint (p, t) -> @@ -591,4 +597,3 @@ let run_main mapper = let register_function = ref (fun _name f -> run_main f) let register name f = !register_function name f - diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index c71db50a7d..326310e4c4 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -28,9 +28,11 @@ type mapper = { class_signature: mapper -> class_signature -> class_signature; class_structure: mapper -> class_structure -> class_structure; class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration -> class_type_declaration; + class_type_declaration: mapper -> class_type_declaration + -> class_type_declaration; class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration -> constructor_declaration; + constructor_declaration: mapper -> constructor_declaration + -> constructor_declaration; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; label_declaration: mapper -> label_declaration -> label_declaration; @@ -39,7 +41,8 @@ type mapper = { module_declaration: mapper -> module_declaration -> module_declaration; module_expr: mapper -> module_expr -> module_expr; module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration -> module_type_declaration; + module_type_declaration: mapper -> module_type_declaration + -> module_type_declaration; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; signature: mapper -> signature -> signature; diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 910027c044..15fa177fb8 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -236,8 +236,9 @@ let report_error ppf = function | Unterminated_string -> fprintf ppf "String literal not terminated" | Unterminated_string_in_comment (_, loc) -> - fprintf ppf "This comment contains an unterminated string literal@.%aString literal begins here" - Location.print_error loc + fprintf ppf "This comment contains an unterminated string literal@.\ + %aString literal begins here" + Location.print_error loc | Keyword_as_label kwd -> fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd | Literal_overflow ty -> @@ -255,7 +256,7 @@ let () = } -let newline = ('\013'* '\010' ) +let newline = ('\013'* '\010') let blank = [' ' '\009' '\012'] let lowercase = ['a'-'z' '_'] let uppercase = ['A'-'Z'] @@ -519,7 +520,8 @@ and comment = parse | loc :: _ -> let start = List.hd (List.rev !comment_start_loc) in comment_start_loc := []; - raise (Error (Unterminated_string_in_comment (start, str_start), loc)) + raise (Error (Unterminated_string_in_comment (start, str_start), + loc)) end; is_in_string := false; store_string_char '|'; diff --git a/parsing/location.ml b/parsing/location.ml index 132021f5b9..669f2a2433 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -333,7 +333,8 @@ let rec report_error ppf ({loc; msg; sub; if_highlight} as err) = else begin print ppf loc; Format.pp_print_string ppf msg; - List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) sub + List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) + sub end let error_of_printer loc print x = diff --git a/parsing/location.mli b/parsing/location.mli index e6df9d1f6c..8287d1ec9a 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -69,6 +69,8 @@ val mkloc : 'a -> t -> 'a loc val print: formatter -> t -> unit val print_filename: formatter -> string -> unit +val absolute_path: string -> string + val show_filename: string -> string (** In -absname mode, return the absolute path for this filename. Otherwise, returns the filename unchanged. *) @@ -89,7 +91,8 @@ type error = val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error -val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string -> ('a, unit, string, error) format4 -> 'a +val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string + -> ('a, unit, string, error) format4 -> 'a val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error diff --git a/parsing/parser.mly b/parsing/parser.mly index e6fbdde6df..078c652e00 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -562,7 +562,8 @@ module_expr: | STRUCT structure error { unclosed "struct" 1 "end" 3 } | FUNCTOR functor_args MINUSGREATER module_expr - { List.fold_left (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc))) $4 $2 } + { List.fold_left (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc))) + $4 $2 } | module_expr LPAREN module_expr RPAREN { mkmod(Pmod_apply($1, $3)) } | module_expr LPAREN RPAREN @@ -689,7 +690,8 @@ module_type: { unclosed "sig" 1 "end" 3 } | FUNCTOR functor_args MINUSGREATER module_type %prec below_WITH - { List.fold_left (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc))) $4 $2 } + { List.fold_left (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc))) + $4 $2 } | module_type WITH with_constraints { mkmty(Pmty_with($1, List.rev $3)) } | MODULE TYPE OF module_expr %prec below_LBRACKETAT @@ -784,7 +786,8 @@ class_declarations: | class_declaration { [$1] } ; class_declaration: - virtual_flag class_type_parameters LIDENT class_fun_binding post_item_attributes + virtual_flag class_type_parameters LIDENT class_fun_binding + post_item_attributes { Ci.mk (mkrhs $3 3) $4 ~virt:$1 ~params:$2 @@ -904,13 +907,16 @@ method_: { if $1 = Override then syntax_error (); mkloc $4 (rhs_loc 4), $3, Cfk_virtual $6 } | override_flag private_flag label strict_binding - { mkloc $3 (rhs_loc 3), $2, Cfk_concrete ($1, ghexp(Pexp_poly ($4, None))) } + { mkloc $3 (rhs_loc 3), $2, + Cfk_concrete ($1, ghexp(Pexp_poly ($4, None))) } | override_flag private_flag label COLON poly_type EQUAL seq_expr - { mkloc $3 (rhs_loc 3), $2, Cfk_concrete ($1, ghexp(Pexp_poly($7, Some $5))) } + { mkloc $3 (rhs_loc 3), $2, + Cfk_concrete ($1, ghexp(Pexp_poly($7, Some $5))) } | override_flag private_flag label COLON TYPE lident_list DOT core_type EQUAL seq_expr { let exp, poly = wrap_type_annotation $6 $8 $10 in - mkloc $3 (rhs_loc 3), $2, Cfk_concrete ($1, ghexp(Pexp_poly(exp, Some poly))) } + mkloc $3 (rhs_loc 3), $2, + Cfk_concrete ($1, ghexp(Pexp_poly(exp, Some poly))) } ; /* Class types */ @@ -918,7 +924,8 @@ method_: class_type: class_signature { $1 } - | QUESTION LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER class_type + | QUESTION LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER + class_type { mkcty(Pcty_arrow("?" ^ $2 , mkoption $4, $6)) } | OPTLABEL simple_core_type_or_tuple_no_attr MINUSGREATER class_type { mkcty(Pcty_arrow("?" ^ $1, mkoption $2, $4)) } @@ -986,7 +993,8 @@ class_descriptions: | class_description { [$1] } ; class_description: - virtual_flag class_type_parameters LIDENT COLON class_type post_item_attributes + virtual_flag class_type_parameters LIDENT COLON class_type + post_item_attributes { Ci.mk (mkrhs $3 3) $5 ~virt:$1 ~params:$2 @@ -998,7 +1006,8 @@ class_type_declarations: | class_type_declaration { [$1] } ; class_type_declaration: - virtual_flag class_type_parameters LIDENT EQUAL class_signature post_item_attributes + virtual_flag class_type_parameters LIDENT EQUAL class_signature + post_item_attributes { Ci.mk (mkrhs $3 3) $5 ~virt:$1 ~params:$2 @@ -1090,7 +1099,8 @@ expr: { mkexp_attrs (Pexp_ifthenelse($3, $5, None)) $2 } | WHILE ext_attributes seq_expr DO seq_expr DONE { mkexp_attrs (Pexp_while($3, $5)) $2 } - | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO seq_expr DONE + | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO + seq_expr DONE { mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 } | expr COLONCOLON expr { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) } @@ -1157,7 +1167,7 @@ expr: | OBJECT ext_attributes class_structure END { mkexp_attrs (Pexp_object $3) $2 } | OBJECT ext_attributes class_structure error - { unclosed "object" 1 "end" 3 } + { unclosed "object" 1 "end" 4 } | expr attribute { Exp.attr $1 $2 } ; @@ -1245,7 +1255,7 @@ simple_expr: | LBRACELESS GREATERRBRACE { mkexp (Pexp_override [])} | mod_longident DOT LBRACELESS field_expr_list opt_semi GREATERRBRACE - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override(List.rev $4)))) } + { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override(List.rev $4))))} | mod_longident DOT LBRACELESS field_expr_list opt_semi error { unclosed "{<" 3 ">}" 6 } | simple_expr SHARP label @@ -1808,7 +1818,7 @@ core_type_list_no_attr: | core_type_list STAR simple_core_type_no_attr { $3 :: $1 } ; meth_list: - field SEMI meth_list { let (f, c) = $3 in ($1 :: f, c) } + field SEMI meth_list { let (f, c) = $3 in ($1 :: f, c) } | field opt_semi { [$1], Closed } | DOTDOT { [], Open } ; @@ -1822,13 +1832,13 @@ label: /* Constants */ constant: - INT { Const_int $1 } - | CHAR { Const_char $1 } - | STRING { let (s, d) = $1 in Const_string (s, d) } - | FLOAT { Const_float $1 } - | INT32 { Const_int32 $1 } - | INT64 { Const_int64 $1 } - | NATIVEINT { Const_nativeint $1 } + INT { Const_int $1 } + | CHAR { Const_char $1 } + | STRING { let (s, d) = $1 in Const_string (s, d) } + | FLOAT { Const_float $1 } + | INT32 { Const_int32 $1 } + | INT64 { Const_int64 $1 } + | NATIVEINT { Const_nativeint $1 } ; signed_constant: constant { $1 } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index a76be627d8..6c558577dd 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -17,14 +17,19 @@ open Asttypes (** {2 Extension points} *) type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. *) and extension = string loc * payload (* [%id ARG] [%%id ARG] - *) + + Sub-language placeholder -- rejected by the typechecker. + *) and attributes = attribute list @@ -115,7 +120,12 @@ and row_field = [`A of T] ( false, [T] ) [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - *) + + - The 2nd field is true if the tag contains a + constant (empty) constructor. + - '&' occurs when several types are used for the same constructor + (see 4.2 in the manual) + *) | Rinherit of core_type (* [ T ] *) @@ -169,7 +179,8 @@ and pattern_desc = (* lazy P *) | Ppat_unpack of string loc (* (module P) - Note: (module P : S) is represented as Ppat_constraint(Ppat_unpack, Ptyp_package) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_extension of extension (* [%id] *) @@ -266,7 +277,8 @@ and expression_desc = (* let module M = ME in E *) | Pexp_assert of expression (* assert E - Note: "assert false" is treated in a special way by the type-checker. *) + Note: "assert false" is treated in a special way by the + type-checker. *) | Pexp_lazy of expression (* lazy E *) | Pexp_poly of expression * core_type option @@ -690,7 +702,11 @@ and structure_item_desc = | Pstr_modtype of module_type_declaration (* module type S = MT *) | Pstr_open of override_flag * Longident.t loc * attributes - (* open X *) + (* open! X - true + open X - false + + override_flag silences the 'used identifier shadowing' warning + *) | Pstr_class of class_declaration list (* class c1 = ... and ... and cn = ... *) | Pstr_class_type of class_type_declaration list @@ -727,6 +743,7 @@ and module_binding = type toplevel_phrase = | Ptop_def of structure | Ptop_dir of string * directive_argument + (* #use, #load ... *) and directive_argument = | Pdir_none diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index ac7c6d2a30..ff48dafbfb 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -60,7 +60,8 @@ let needs_parens txt = is_infix (fixity_of_string txt) || List.mem txt.[0] prefix_symbols -(* some infixes need spaces around parens to avoid clashes with comment syntax *) +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) let needs_spaces txt = txt.[0]='*' || txt.[String.length txt - 1] = '*' @@ -353,7 +354,8 @@ class printer ()= object(self:'self) | Ppat_alias (p, s) -> pp f "@[<2>%a@;as@;%a@]" self#pattern p protect_ident s.txt (* RA*) | Ppat_or (p1, p2) -> (* *) - pp f "@[<hov0>%a@]" (self#list ~sep:"@,|" self#pattern) (list_of_pattern [] x) + pp f "@[<hov0>%a@]" (self#list ~sep:"@,|" self#pattern) + (list_of_pattern [] x) | _ -> self#pattern1 f x method pattern1 (f:Format.formatter) (x:pattern) :unit = let rec pattern_list_helper f = function @@ -422,11 +424,13 @@ class printer ()= object(self:'self) match p.ppat_desc with | Ppat_var {txt;_} when txt = rest -> (match opt with - |Some o -> pp f "?(%s=@;%a)@;" rest self#expression o - | None -> pp f "?%s@ " rest) - | _ -> (match opt with - | Some o -> pp f "%s:(%a=@;%a)@;" l self#pattern1 p self#expression o - | None -> pp f "%s:%a@;" l self#simple_pattern p ) + | Some o -> pp f "?(%s=@;%a)@;" rest self#expression o + | None -> pp f "?%s@ " rest) + | _ -> + (match opt with + | Some o -> + pp f "%s:(%a=@;%a)@;" l self#pattern1 p self#expression o + | None -> pp f "%s:%a@;" l self#simple_pattern p) end else (match p.ppat_desc with @@ -466,7 +470,8 @@ class printer ()= object(self:'self) end | Pexp_apply ({pexp_desc=Pexp_ident - {txt= Ldot (Ldot (Lident "Bigarray", array), ("get"|"set" as gs)) ;_};_}, + {txt= Ldot (Ldot (Lident "Bigarray", array), + ("get"|"set" as gs)) ;_};_}, label_exprs) -> begin match array,gs with | "Genarray","get" -> @@ -495,7 +500,8 @@ class printer ()= object(self:'self) | (_,v)::rest -> let args = List.map snd (List.rev rest) in pp f "@[%a.{%a}@ <-@ %a@]" - self#simple_expr a (self#list ~sep:"," self#simple_expr) + self#simple_expr a (self#list ~sep:"," + self#simple_expr) args self#simple_expr v; true | _ -> assert false @@ -841,7 +847,7 @@ class printer ()= object(self:'self) pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *) (self#list self#signature_item ) s (* FIXME wrong indentation*) | Pmty_functor (_, None, mt2) -> - pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2 + pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2 | Pmty_functor (s, Some mt1, mt2) -> pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt self#module_type mt1 self#module_type mt2 @@ -1052,7 +1058,7 @@ class printer ()= object(self:'self) | Pmty_signature (_));_} as mt)) -> pp f " :@;%a@;=@;%a@;" self#module_type mt self#module_expr me | _ -> - pp f " =@ %a" self#module_expr me + pp f " =@ %a" self#module_expr me )) x.pmb_expr | Pstr_open (ovf, li, _attrs) -> pp f "@[<2>open%s@;%a@]" (override ovf) self#longident_loc li; diff --git a/parsing/printast.ml b/parsing/printast.ml index 7979e4128b..4cc175b1d4 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -194,7 +194,8 @@ and pattern i ppf x = line i ppf "Ppat_alias %a\n" fmt_string_loc s; pattern i ppf p; | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; - | Ppat_interval (c1, c2) -> line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; + | Ppat_interval (c1, c2) -> + line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; | Ppat_tuple (l) -> line i ppf "Ppat_tuple\n"; list i pattern ppf l; @@ -356,7 +357,8 @@ and expression i ppf x = payload i ppf arg and value_description i ppf x = - line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location x.pval_loc; + line i ppf "value_description %a %a\n" fmt_string_loc + x.pval_name fmt_location x.pval_loc; attributes i ppf x.pval_attributes; core_type (i+1) ppf x.pval_type; list (i+1) string ppf x.pval_prim @@ -369,7 +371,8 @@ and type_parameter i ppf (x, _variance) = string i ppf "_" and type_declaration i ppf x = - line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name fmt_location x.ptype_loc; + line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name + fmt_location x.ptype_loc; attributes i ppf x.ptype_attributes; let i = i+1 in line i ppf "ptype_params =\n"; @@ -449,7 +452,8 @@ and class_type_field i ppf x = fmt_virtual_flag vf; core_type (i+1) ppf ct; | Pctf_method (s, pf, vf, ct) -> - line i ppf "Pctf_method \"%s\" %a %a\n" s fmt_private_flag pf fmt_virtual_flag vf; + line i ppf "Pctf_method \"%s\" %a %a\n" s fmt_private_flag pf + fmt_virtual_flag vf; core_type (i+1) ppf ct; | Pctf_constraint (ct1, ct2) -> line i ppf "Pctf_constraint\n"; @@ -764,7 +768,8 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; -and constructor_decl i ppf {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = +and constructor_decl i ppf + {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = line i ppf "%a\n" fmt_location pcd_loc; attributes i ppf pcd_attributes; line (i+1) ppf "%a\n" fmt_string_loc pcd_name; @@ -774,7 +779,7 @@ and constructor_decl i ppf {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes end; option (i+1) core_type ppf pcd_res -and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes} = +and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= line i ppf "%a\n" fmt_location pld_loc; attributes i ppf pld_attributes; line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; diff --git a/stdlib/Makefile b/stdlib/Makefile index 80be16e0b2..37f9a5f0bf 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -25,19 +25,22 @@ allopt-prof: stdlib.p.cmxa std_exit.p.cmx installopt: installopt-default installopt-$(PROFILING) installopt-default: - cp stdlib.cmxa stdlib.a std_exit.o *.cmx $(LIBDIR) - cd $(LIBDIR); $(RANLIB) stdlib.a + cp stdlib.cmxa stdlib.a std_exit.o *.cmx $(INSTALL_LIBDIR) + cd $(INSTALL_LIBDIR); $(RANLIB) stdlib.a installopt-noprof: - rm -f $(LIBDIR)/stdlib.p.cmxa; ln -s stdlib.cmxa $(LIBDIR)/stdlib.p.cmxa - rm -f $(LIBDIR)/stdlib.p.a; ln -s stdlib.a $(LIBDIR)/stdlib.p.a - rm -f $(LIBDIR)/std_exit.p.cmx; \ - ln -s std_exit.cmx $(LIBDIR)/std_exit.p.cmx - rm -f $(LIBDIR)/std_exit.p.o; ln -s std_exit.o $(LIBDIR)/std_exit.p.o + rm -f $(INSTALL_LIBDIR)/stdlib.p.cmxa; \ + ln -s stdlib.cmxa $(INSTALL_LIBDIR)/stdlib.p.cmxa + rm -f $(INSTALL_LIBDIR)/stdlib.p.a; \ + ln -s stdlib.a $(INSTALL_LIBDIR)/stdlib.p.a + rm -f $(INSTALL_LIBDIR)/std_exit.p.cmx; \ + ln -s std_exit.cmx $(INSTALL_LIBDIR)/std_exit.p.cmx + rm -f $(INSTALL_LIBDIR)/std_exit.p.o; \ + ln -s std_exit.o $(INSTALL_LIBDIR)/std_exit.p.o installopt-prof: - cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o $(LIBDIR) - cd $(LIBDIR); $(RANLIB) stdlib.p.a + cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o $(INSTALL_LIBDIR) + cd $(INSTALL_LIBDIR); $(RANLIB) stdlib.p.a stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx) $(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx) diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt index b85622b90b..590701bf92 100644 --- a/stdlib/Makefile.nt +++ b/stdlib/Makefile.nt @@ -16,7 +16,7 @@ include Makefile.shared allopt: stdlib.cmxa std_exit.cmx installopt: - cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR) + cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(INSTALL_LIBDIR) camlheader camlheader_ur: headernt.c ../config/Makefile $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \ diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared index 80c40d6002..1de2b73059 100755 --- a/stdlib/Makefile.shared +++ b/stdlib/Makefile.shared @@ -38,15 +38,17 @@ OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ all: stdlib.cma std_exit.cmo camlheader camlheader_ur +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install: install-$(RUNTIMED) cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \ - $(LIBDIR) + $(INSTALL_LIBDIR) install-noruntimed: .PHONY: install-noruntimed install-runtimed: camlheaderd - cp camlheaderd $(LIBDIR) + cp camlheaderd $(INSTALL_LIBDIR) .PHONY: install-runtimed stdlib.cma: $(OBJS) diff --git a/stdlib/arg.mli b/stdlib/arg.mli index e6e07316dc..22eda40b74 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -94,7 +94,7 @@ val parse : *) val parse_dynamic : - (key * spec * doc) list ref -> anon_fun -> string -> unit + (key * spec * doc) list ref -> anon_fun -> usage_msg -> unit (** Same as {!Arg.parse}, except that the [speclist] argument is a reference and may be updated during the parsing. A typical use for this feature is to parse command lines of the form: diff --git a/stdlib/digest.ml b/stdlib/digest.ml index 2baf3dbfa3..7c607ee1f8 100644 --- a/stdlib/digest.ml +++ b/stdlib/digest.ml @@ -42,7 +42,8 @@ let input chan = really_input chan digest 0 16; digest -let char_hex n = Char.unsafe_chr (n + if n < 10 then Char.code '0' else (Char.code 'a' - 10)) +let char_hex n = + Char.unsafe_chr (n + if n < 10 then Char.code '0' else (Char.code 'a' - 10)) let to_hex d = let result = String.create 32 in diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml index e4a07c3dea..7c0f14298a 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml @@ -37,6 +37,20 @@ exception Exit external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(* Debugging *) + +external __LOC__ : string = "%loc_LOC" +external __FILE__ : string = "%loc_FILE" +external __LINE__ : int = "%loc_LINE" +external __MODULE__ : string = "%loc_MODULE" +external __POS__ : string * int * int * int = "%loc_POS" + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +external __FILE_OF__ : 'a -> string * 'a = "%loc_FILE" +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +external __MODULE_OF__ : 'a -> string * 'a = "%loc_MODULE" +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" + (* Comparisons *) external ( = ) : 'a -> 'a -> bool = "%equal" diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 0a2e4af6a6..1ee09984c7 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -140,6 +140,19 @@ external ( || ) : bool -> bool -> bool = "%sequor" external ( or ) : bool -> bool -> bool = "%sequor" (** @deprecated {!Pervasives.( || )} should be used instead.*) +(** {6 Debugging} *) + +external __LOC__ : string = "%loc_LOC" +external __FILE__ : string = "%loc_FILE" +external __LINE__ : int = "%loc_LINE" +external __MODULE__ : string = "%loc_MODULE" +external __POS__ : string * int * int * int = "%loc_POS" + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +external __FILE_OF__ : 'a -> string * 'a = "%loc_FILE" +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +external __MODULE_OF__ : 'a -> string * 'a = "%loc_MODULE" +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" (** {6 Composition operators} *) diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli index c378d9cb32..f662e501bd 100644 --- a/stdlib/printexc.mli +++ b/stdlib/printexc.mli @@ -130,5 +130,3 @@ val exn_slot_name: exn -> string @since 4.02.0 *) - - diff --git a/stdlib/queue.mli b/stdlib/queue.mli index 55e8988329..5cd1136e4c 100644 --- a/stdlib/queue.mli +++ b/stdlib/queue.mli @@ -16,7 +16,7 @@ This module implements queues (FIFOs), with in-place modification. {b Warning} This module is not thread-safe: each {!Queue.t} value - must be protected from concurrent access (e.g. with a {!Mutex.t}). + must be protected from concurrent access (e.g. with a [Mutex.t]). Failure to do so can lead to a crash. *) diff --git a/stdlib/set.ml b/stdlib/set.ml index 1d049b139a..5c6212d889 100644 --- a/stdlib/set.ml +++ b/stdlib/set.ml @@ -363,7 +363,8 @@ module Make(Ord: OrderedType) = | 0, l -> Empty, l | 1, x0 :: l -> Node (Empty, x0, Empty, 1), l | 2, x0 :: x1 :: l -> Node (Node(Empty, x0, Empty, 1), x1, Empty, 2), l - | 3, x0 :: x1 :: x2 :: l -> Node (Node(Empty, x0, Empty, 1), x1, Node(Empty, x2, Empty, 1), 2), l + | 3, x0 :: x1 :: x2 :: l -> + Node (Node(Empty, x0, Empty, 1), x1, Node(Empty, x2, Empty, 1), 2),l | n, l -> let nl = n / 2 in let left, l = sub nl l in diff --git a/testsuite/Makefile b/testsuite/Makefile index 813f4dabb7..668f0833ae 100644 --- a/testsuite/Makefile +++ b/testsuite/Makefile @@ -11,7 +11,8 @@ ######################################################################### BASEDIR := $(shell pwd) -NO_PRINT=`$(MAKE) empty --no-print-directory >/dev/null 2>&1 && echo '--no-print-directory'` +NO_PRINT=`$(MAKE) empty --no-print-directory >/dev/null 2>&1 \ + && echo --no-print-directory` FIND=find include ../config/Makefile @@ -20,12 +21,12 @@ include ../config/Makefile default: @echo "Available targets:" @echo " all launch all tests" - @echo " list FILE=f launch the tests referenced in file f (one path per line)" + @echo " list FILE=f launch the tests listed in f (one per line)" @echo " one DIR=p launch the tests located in path p" - @echo " promote DIR=p promote the reference files for the tests located in path p" + @echo " promote DIR=p promote the reference files for the tests in p" @echo " lib build library modules" @echo " clean delete generated files" - @echo " report print the report for the last execution, if any" + @echo " report print the report for the last execution" .PHONY: all all: lib diff --git a/testsuite/external/.ignore b/testsuite/external/.ignore index 8d1415349c..8b57bbb1eb 100644 --- a/testsuite/external/.ignore +++ b/testsuite/external/.ignore @@ -47,6 +47,8 @@ corekernel core_kernel-109.37.00 cryptokit cryptokit-1.6 +csv +csv-1.3.1 customprintf custom_printf-109.27.00 dbm @@ -60,7 +62,7 @@ fieldslib-109.15.00 fileutils ocaml-fileutils-0.4.4 findlib -findlib-1.3.3 +findlib-1.4.1 framac frama-c-Oxygen-20120901 geneweb @@ -140,7 +142,7 @@ variantslib-109.15.00 vsyml vsyml-2010-04-06 xmllight -xml-light-2.2 +xml-light.2.3 xmlm xmlm-1.1.0 zarith diff --git a/testsuite/external/Makefile b/testsuite/external/Makefile index c91e98084c..33acd2ae64 100644 --- a/testsuite/external/Makefile +++ b/testsuite/external/Makefile @@ -42,12 +42,12 @@ all-cygwin: findlib ounit res pcre react ocamltext ocamlssl camlzip cryptokit \ camomile zen vsyml extlib fileutils ocamlify ocamlmod \ calendar dbm ocamlscript coq compcert -all-macos: findlib lablgtk ocamlgraph ounit res pcre core react ocamltext \ - ocamlssl lwt camlzip cryptokit sqlite menhir hevea \ - unison ocgi xmllight configfile xmlm lablgtkextras sks omake \ - altergo boomerang camomile zen vsyml ocamlnet extlib fileutils \ - odn ocamlify expect ocamlmod oasis calendar camlimages advi \ - dbm ocsigen ocamlscript coq compcert framac +all-macos: findlib res pcre react ocamltext \ + ocamlssl camlzip cryptokit sqlite menhir hevea \ + xmllight xmlm omake \ + altergo boomerang vsyml extlib \ + ocamlify calendar \ + dbm framac platform: case `uname -s` in \ @@ -61,7 +61,7 @@ CAMLP4=camlp4-trunk ${CAMLP4}.zip: ${WGET} https://github.com/ocaml/camlp4/archive/trunk.zip mv trunk.zip ${CAMLP4}.zip -camlp4: ${CAMLP4}.zip +xxcamlp4: ${CAMLP4}.zip printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${CAMLP4} @@ -81,10 +81,10 @@ distclean:: all: camlp4 # http://projects.camlcity.org/projects/findlib.html -FINDLIB=findlib-1.3.3 +FINDLIB=findlib-1.4.1 ${FINDLIB}.tar.gz: ${WGET} http://download.camlcity.org/download/$@ -findlib: ${FINDLIB}.tar.gz camlp4 +findlib: ${FINDLIB}.tar.gz printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${FINDLIB} @@ -107,7 +107,7 @@ all: findlib LABLGTK=lablgtk-2.18.0 ${LABLGTK}.tar.gz: ${WGET} https://forge.ocamlcore.org/frs/download.php/1261/$@ -lablgtk: ${LABLGTK}.tar.gz findlib # TODO: add lablgl +xxlablgtk: ${LABLGTK}.tar.gz findlib camlp4 # TODO: add lablgl printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${LABLGTK} @@ -133,7 +133,7 @@ all: lablgtk OCAMLGRAPH=ocamlgraph-1.8.2 ${OCAMLGRAPH}.tar.gz: ${WGET} http://ocamlgraph.lri.fr/download/$@ -ocamlgraph: ${OCAMLGRAPH}.tar.gz findlib lablgtk +ocamlgraph: ${OCAMLGRAPH}.tar.gz findlib printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OCAMLGRAPH} @@ -159,7 +159,7 @@ all: ocamlgraph OUNIT=ounit-1.1.2 ${OUNIT}.tar.gz: ${WGET} http://forge.ocamlcore.org/frs/download.php/886/$@ -ounit: ${OUNIT}.tar.gz findlib +xxounit: ${OUNIT}.tar.gz findlib camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OUNIT} @@ -229,7 +229,7 @@ all: pcre TYPECONV=type_conv-109.28.00 ${TYPECONV}.tar.gz: ${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@ -typeconv: ${TYPECONV}.tar.gz findlib +xxtypeconv: ${TYPECONV}.tar.gz findlib camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${TYPECONV} @@ -252,7 +252,7 @@ all: typeconv VARIANTSLIB=variantslib-109.15.00 ${VARIANTSLIB}.tar.gz: ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ -variantslib: ${VARIANTSLIB}.tar.gz findlib typeconv +xxvariantslib: ${VARIANTSLIB}.tar.gz findlib typeconv printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${VARIANTSLIB} @@ -460,7 +460,7 @@ all: core CORE=core-109.37.00 ${CORE}.tar.gz: ${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@ -core: ${CORE}.tar.gz findlib variantslib sexplib fieldslib binprot comparelib \ +xxcore: ${CORE}.tar.gz findlib variantslib sexplib fieldslib binprot comparelib \ paounit pipebang res ounit corekernel printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -626,7 +626,7 @@ all: ocamlssl LWT=lwt-2.4.0 ${LWT}.tar.gz: ${WGET} http://ocsigen.org/download/$@ -lwt: ${LWT}.tar.gz findlib react ocamltext ocamlssl lablgtk +xxlwt: ${LWT}.tar.gz findlib react ocamltext ocamlssl camlp4 lablgtk printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${LWT} @@ -836,7 +836,7 @@ all: mysql OCGI=ocgi-0.5 ${OCGI}.tar.gz: ${WGET} http://pauillac.inria.fr/~guesdon/Tools/Tars/$@ -ocgi: ${OCGI}.tar.gz +ocgi: ${OCGI}.tar.gz camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OCGI} @@ -856,20 +856,20 @@ distclean:: all: ocgi # http://tech.motion-twin.com/xmllight -XMLLIGHT=xml-light-2.2 -${XMLLIGHT}.zip: - ${WGET} http://tech.motion-twin.com/zip/$@ -xmllight: ${XMLLIGHT}.zip +XMLLIGHT=xml-light.2.3 +${XMLLIGHT}.tar.gz: + ${WGET} https://github.com/bguil/ocamllibs/releases/download/xml-light.2.3/$@ +xmllight: ${XMLLIGHT}.tar.gz printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf xml-light ${XMLLIGHT} - unzip ${XMLLIGHT}.zip && mv xml-light ${XMLLIGHT} + tar zxf ${XMLLIGHT}.tar.gz ./Patcher.sh ${XMLLIGHT} ( cd ${XMLLIGHT} && \ export PATH=${PREFIX}/bin:$$PATH && \ ${MAKE} xml_parser.ml && \ ${MAKE} all opt && \ - ${MAKE} install ) + ${MAKE} install_ocamlfind ) echo ${VERSION} >$@ clean:: rm -rf ${XMLLIGHT} xml-light xmllight @@ -881,7 +881,7 @@ all: xmllight CONFIGFILE=config-file-1.1 ${CONFIGFILE}.tar.gz: ${WGET} https://forge.ocamlcore.org/frs/download.php/845/$@ -configfile: ${CONFIGFILE}.tar.gz +configfile: ${CONFIGFILE}.tar.gz camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${CONFIGFILE} @@ -950,7 +950,7 @@ all: lablgtkextras SKS=sks-1.1.3 ${SKS}.tgz: ${WGET} https://bitbucket.org/skskeyserver/sks-keyserver/downloads/$@ -sks: ${SKS}.tgz +sks: ${SKS}.tgz camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${SKS} @@ -1060,7 +1060,7 @@ all: boomerang CAMOMILE=camomile-0.8.4 ${CAMOMILE}.tar.bz2: ${WGET} https://github.com/downloads/yoriyuki/Camomile/$@ -camomile: ${CAMOMILE}.tar.bz2 +camomile: ${CAMOMILE}.tar.bz2 camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${CAMOMILE} @@ -1083,7 +1083,7 @@ all: camomile ZEN=zen_2.3.2 ${ZEN}.tar.gz: ${WGET} http://sanskrit.inria.fr/ZEN/$@ -zen: ${ZEN}.tar.gz +zen: ${ZEN}.tar.gz camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${ZEN} @@ -1125,7 +1125,7 @@ all: vsyml OCAMLNET=ocamlnet-3.5.1 ${OCAMLNET}.tar.gz: ${WGET} http://download.camlcity.org/download/$@ -ocamlnet: ${OCAMLNET}.tar.gz findlib pcre lablgtk ocamlssl camlzip cryptokit +ocamlnet: ${OCAMLNET}.tar.gz findlib pcre camlp4 ocamlssl camlzip cryptokit printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OCAMLNET} @@ -1208,7 +1208,7 @@ all: extlib FILEUTILS=ocaml-fileutils-0.4.4 ${FILEUTILS}.tar.gz: ${WGET} http://forge.ocamlcore.org/frs/download.php/892/$@ -fileutils: ${FILEUTILS}.tar.gz findlib ounit +xxfileutils: ${FILEUTILS}.tar.gz findlib ounit printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${FILEUTILS} @@ -1370,7 +1370,7 @@ CAMLIMAGES=camlimages-4.0.1 ${CAMLIMAGES}.tar.gz: ${WGET} https://bitbucket.org/camlspotter/camlimages/get/v4.0.1.tar.gz mv v4.0.1.tar.gz $@ -camlimages: ${CAMLIMAGES}.tar.gz findlib omake lablgtk +xxcamlimages: ${CAMLIMAGES}.tar.gz findlib omake lablgtk printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${CAMLIMAGES} @@ -1488,7 +1488,7 @@ all: mldonkey OCAMLSCRIPT=ocamlscript-2.0.3 ${OCAMLSCRIPT}.tar.gz: ${WGET} http://mjambon.com/releases/ocamlscript/$@ -ocamlscript: ${OCAMLSCRIPT}.tar.gz findlib +ocamlscript: ${OCAMLSCRIPT}.tar.gz findlib camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OCAMLSCRIPT} @@ -1529,7 +1529,7 @@ distclean:: rm -f ${KAPUTT}.tar.gz all: kaputt -#http://www.coherentpdf.com/ocaml-libraries.html +# http://www.coherentpdf.com/ocaml-libraries.html CAMLPDF=camlpdf-0.5 ${CAMLPDF}.tar.bz2: ${WGET} http://www.coherentpdf.com/$@ @@ -1550,6 +1550,29 @@ distclean:: rm -f ${CAMLPDF}.tar.gz all: camlpdf +# https://forge.ocamlcore.org/projects/csv +CSV=csv-1.3.1 +${CSV}.tar.gz: + ${WGET} https://forge.ocamlcore.org/frs/download.php/1235/$@ +csv: ${CSV}.tar.gz findlib + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${CSV} + tar zxf ${CSV}.tar.gz + ./Patcher.sh ${CSV} + ( cd ${CSV} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + ocaml setup.ml -configure --enable-tests --prefix ${PREFIX} && \ + ocaml setup.ml -build && \ + ocamlfind remove csv && \ + ocaml setup.ml -install ) + echo ${VERSION} >$@ +clean:: + rm -rf ${CSV} csv +distclean:: + rm -f ${CSV}.tar.gz +all: csv + # disabled: need to be updated for new AST stuff # # http://pauillac.inria.fr/~ddr/camlp5/ # CAMLP5=camlp5-6.10 @@ -1599,7 +1622,7 @@ all: camlpdf COQ=coq-8.4pl2 ${COQ}.tar.gz: ${WGET} http://coq.inria.fr/distrib/V8.4pl2/files/$@ -coq: ${COQ}.tar.gz +xxcoq: ${COQ}.tar.gz camlp5 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${COQ} @@ -1669,7 +1692,7 @@ all: compcert FRAMAC=frama-c-Oxygen-20120901 ${FRAMAC}.tar.gz: ${WGET} http://frama-c.com/download/$@ -framac: ${FRAMAC}.tar.gz lablgtk ocamlgraph altergo coq +framac: ${FRAMAC}.tar.gz printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${FRAMAC} diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index aa37bf9e4b..501d0594d3 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -23,7 +23,7 @@ INCLUDES=\ OTHEROBJS=\ $(OTOPDIR)/compilerlibs/ocamlcommon.cma \ - $(OTOPDIR)/compilerlibs/ocamloptcomp.cma + $(OTOPDIR)/compilerlibs/ocamloptcomp.cma OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo diff --git a/testsuite/tests/asmcomp/arm64.S b/testsuite/tests/asmcomp/arm64.S index 3bb4110618..7b839c44af 100644 --- a/testsuite/tests/asmcomp/arm64.S +++ b/testsuite/tests/asmcomp/arm64.S @@ -12,21 +12,21 @@ .globl call_gen_code .align 2 -call_gen_code: +call_gen_code: /* Set up stack frame and save callee-save registers */ - stp x29, x30, [sp, -160]! - add x29, sp, #0 + stp x29, x30, [sp, -160]! + add x29, sp, #0 stp x19, x20, [sp, 16] stp x21, x22, [sp, 32] stp x23, x24, [sp, 48] stp x25, x26, [sp, 64] stp x27, x28, [sp, 80] - stp d8, d9, [sp, 96] + stp d8, d9, [sp, 96] stp d10, d11, [sp, 112] stp d12, d13, [sp, 128] stp d14, d15, [sp, 144] /* Shuffle arguments */ - mov x8, x0 + mov x8, x0 mov x0, x1 mov x1, x2 mov x2, x3 @@ -39,14 +39,14 @@ call_gen_code: ldp x23, x24, [sp, 48] ldp x25, x26, [sp, 64] ldp x27, x28, [sp, 80] - ldp d8, d9, [sp, 96] + ldp d8, d9, [sp, 96] ldp d10, d11, [sp, 112] ldp d12, d13, [sp, 128] ldp d14, d15, [sp, 144] - ldp x29, x30, [sp], 160 + ldp x29, x30, [sp], 160 ret .globl caml_c_call .align 2 caml_c_call: - br x15 + br x15 diff --git a/testsuite/tests/asmcomp/optargs.ml b/testsuite/tests/asmcomp/optargs.ml index d508672394..a4f4040703 100644 --- a/testsuite/tests/asmcomp/optargs.ml +++ b/testsuite/tests/asmcomp/optargs.ml @@ -18,6 +18,4 @@ let () = done; let x2 = Gc.allocated_bytes () in assert(x1 -. x0 = x2 -. x1) - (* check that we did not allocated anything between x1 and x2 *) - - + (* check that we have not allocated anything between x1 and x2 *) diff --git a/testsuite/tests/basic/divint.ml b/testsuite/tests/basic/divint.ml index 6dd4be3fc8..52d14b9c85 100644 --- a/testsuite/tests/basic/divint.ml +++ b/testsuite/tests/basic/divint.ml @@ -32,7 +32,7 @@ let test_one (df: int -> int) (mf: int -> int) x = let do_test divisor (df: int -> int) (mf: int -> int) = d := divisor; List.iter (test_one df mf) - [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; + [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 100; 1000; 10000; 100000; 1000000; max_int - 1; max_int; -1; -2; -3; -4; -5; -6; -7; -8; -9; -10; -100; -1000; -10000; -100000; -1000000; min_int + 1; min_int]; @@ -59,7 +59,7 @@ let test_one (df: nativeint -> nativeint) (mf: nativeint -> nativeint) x = let do_test divisor (df: nativeint -> nativeint) (mf: nativeint -> nativeint) = d := Nativeint.of_int divisor; List.iter (test_one df mf) - [0n; 1n; 2n; 3n; 4n; 5n; 6n; 7n; 8n; 9n; 10n; + [0n; 1n; 2n; 3n; 4n; 5n; 6n; 7n; 8n; 9n; 10n; 100n; 1000n; 10000n; 100000n; 1000000n; Nativeint.(pred max_int); Nativeint.max_int; -1n; -2n; -3n; -4n; -5n; -6n; -7n; -8n; -9n; -10n; diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml index 199f6fe4da..38b0d2b0c1 100644 --- a/testsuite/tests/basic/maps.ml +++ b/testsuite/tests/basic/maps.ml @@ -19,7 +19,18 @@ let show m = IntMap.iter (fun k v -> Printf.printf "%d %s\n" k v) m let () = print_endline "Union+concat"; - show (IntMap.merge (fun _ l r -> match l, r with Some x, None | None, Some x -> Some x | Some x, Some y -> Some (x ^ x) | _ -> assert false) m1 m2); + let f1 _ l r = + match l, r with + | Some x, None | None, Some x -> Some x + | Some x, Some y -> Some (x ^ x) + | _ -> assert false + in + show (IntMap.merge f1 m1 m2); print_endline "Inter"; - show (IntMap.merge (fun _ l r -> match l, r with Some x, Some y when x = y -> Some x | _ -> None) m1 m2); + let f2 _ l r = + match l, r with + | Some x, Some y when x = y -> Some x + | _ -> None + in + show (IntMap.merge f2 m1 m2); () diff --git a/testsuite/tests/basic/tailcalls.ml b/testsuite/tests/basic/tailcalls.ml index 666acb45f3..9a9293aef8 100644 --- a/testsuite/tests/basic/tailcalls.ml +++ b/testsuite/tests/basic/tailcalls.ml @@ -35,6 +35,8 @@ let indtailcall16 fn a b c d e f g h i j k l m n o p = let _ = print_int (tailcall4 10000000 0 0 0); print_newline(); print_int (tailcall8 10000000 0 0 0 0 0 0 0); print_newline(); - print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline(); + print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); + print_newline(); print_int (indtailcall8 tailcall8 10 0 0 0 0 0 0 0); print_newline(); - print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline() + print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); + print_newline() diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml index c259061eb0..906826fae6 100644 --- a/testsuite/tests/lib-bigarray-2/bigarrfml.ml +++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml @@ -38,10 +38,14 @@ let test test_number answer correct_answer = (* External C and Fortran functions *) -external c_filltab : unit -> (float, float64_elt, c_layout) Array2.t = "c_filltab" -external c_printtab : (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab" -external fortran_filltab : unit -> (float, float32_elt, fortran_layout) Array2.t = "fortran_filltab" -external fortran_printtab : (float, float32_elt, fortran_layout) Array2.t -> unit = "fortran_printtab" +external c_filltab : + unit -> (float, float64_elt, c_layout) Array2.t = "c_filltaab" +external c_printtab : + (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab" +external fortran_filltab : + unit -> (float, float32_elt, fortran_layout) Array2.t = "fortran_filltab" +external fortran_printtab : + (float, float32_elt, fortran_layout) Array2.t -> unit = "fortran_printtab" let _ = diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml index 333c175472..5ac8e7f742 100644 --- a/testsuite/tests/lib-bigarray/bigarrays.ml +++ b/testsuite/tests/lib-bigarray/bigarrays.ml @@ -433,7 +433,8 @@ let _ = (check_array2 (make_array2 float64 c_layout 0 10 20 float) 0 10 20 float); test 6 true - (check_array2 (make_array2 int16_signed fortran_layout 1 10 20 id) 1 10 20 id); + (check_array2 (make_array2 int16_signed fortran_layout 1 10 20 id) + 1 10 20 id); test 7 true (check_array2 (make_array2 int fortran_layout 1 10 20 id) 1 10 20 id); test 8 true @@ -494,10 +495,14 @@ let _ = test 1 true !ok; let b = Array2.create float32 fortran_layout 3 3 in - for i = 1 to 3 do for j = 1 to 3 do Array2.unsafe_set b i j (float(i-j)) done done; + for i = 1 to 3 do + for j = 1 to 3 do Array2.unsafe_set b i j (float(i-j)) done + done; let ok = ref true in for i = 1 to 3 do - for j = 1 to 3 do if Array2.unsafe_get b i j <> float(i-j) then ok := false done + for j = 1 to 3 do + if Array2.unsafe_get b i j <> float(i-j) then ok := false + done done; test 2 true !ok; @@ -541,9 +546,12 @@ let _ = test 4 (Array2.slice_left a 3) (from_list int [3000;3001;3002]); test 5 (Array2.slice_left a 4) (from_list int [4000;4001;4002]); let a = make_array2 int fortran_layout 1 5 3 id in - test 6 (Array2.slice_right a 1) (from_list_fortran int [1001;2001;3001;4001;5001]); - test 7 (Array2.slice_right a 2) (from_list_fortran int [1002;2002;3002;4002;5002]); - test 8 (Array2.slice_right a 3) (from_list_fortran int [1003;2003;3003;4003;5003]); + test 6 (Array2.slice_right a 1) + (from_list_fortran int [1001;2001;3001;4001;5001]); + test 7 (Array2.slice_right a 2) + (from_list_fortran int [1002;2002;3002;4002;5002]); + test 8 (Array2.slice_right a 3) + (from_list_fortran int [1003;2003;3003;4003;5003]); (* Tri-dimensional arrays *) @@ -587,7 +595,8 @@ let _ = (check_array3 (make_array3 float64 c_layout 0 4 5 6 float) 0 4 5 6 float); test 6 true - (check_array3 (make_array3 int16_signed fortran_layout 1 4 5 6 id) 1 4 5 6 id); + (check_array3 (make_array3 int16_signed fortran_layout 1 4 5 6 id) + 1 4 5 6 id); test 7 true (check_array3 (make_array3 int fortran_layout 1 4 5 6 id) 1 4 5 6 id); test 8 true @@ -641,7 +650,8 @@ let _ = done done done; let ok = ref true in for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do - if Int32.to_int (Array3.unsafe_get a i j k) <> (i lsl 4) + (j lsl 2) + k then ok := false + if Int32.to_int (Array3.unsafe_get a i j k) <> (i lsl 4) + (j lsl 2) + k + then ok := false done done done; test 1 true !ok; @@ -675,7 +685,8 @@ let _ = let c = reshape_1 (genarray_of_array2 a) 12 in test 1 c (from_list int [0;1;2;3;1000;1001;1002;1003;2000;2001;2002;2003]); let d = reshape_1 (genarray_of_array2 b) 12 in - test 2 d (from_list_fortran int [1001;2001;3001;1002;2002;3002;1003;2003;3003;1004;2004;3004]); + test 2 d (from_list_fortran int + [1001;2001;3001;1002;2002;3002;1003;2003;3003;1004;2004;3004]); testing_function "reshape_2"; let c = reshape_2 (genarray_of_array2 a) 4 3 in test 1 (Array2.slice_left c 0) (from_list int [0;1;2]); @@ -718,7 +729,8 @@ let _ = test_structured_io 11 (make_array3 int32 c_layout 0 20 30 40 Int32.of_int); test_structured_io 12 (make_array3 float32 fortran_layout 1 10 50 100 float); test_structured_io 13 (make_array2 complex32 c_layout 0 100 100 makecomplex); - test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30 makecomplex); + test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30 + makecomplex); testing_function "map_file"; let mapped_file = Filename.temp_file "bigarray" ".data" in diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml index 66cd467500..f9bcf9289f 100644 --- a/testsuite/tests/lib-digest/md5.ml +++ b/testsuite/tests/lib-digest/md5.ml @@ -201,7 +201,9 @@ let test hex s = let res = finish ctx in let exp = Digest.string s in let ok = res = exp && Digest.to_hex exp = hex in - if not ok then Printf.printf "Failure for %S : %S %S %S %S\n" s res exp (Digest.to_hex exp) hex; + if not ok then + Printf.printf "Failure for %S : %S %S %S %S\n" s res exp + (Digest.to_hex exp) hex; ok let time msg iter fn = @@ -215,12 +217,16 @@ let _ = if test "d41d8cd98f00b204e9800998ecf8427e" "" && test "0cc175b9c0f1b6a831c399e269772661" "a" && test "900150983cd24fb0d6963f7d28e17f72" "abc" - && test "8215ef0796a20bcaaae116d3876c664a" "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + && test "8215ef0796a20bcaaae116d3876c664a" + "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" && test "7707d6ae4e027c70eea2a935c2296f21" (String.make 1_000_000 'a') && test "f96b697d7cb7938d525a2f31aaf161d0" "message digest" - && test "d174ab98d277d9f5a5611c2c9f419d9f" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - && test "9e107d9d372bb6826bd81d3542a419d6" "The quick brown fox jumps over the lazy dog" - && test "e4d909c290d0fb1ca068ffaddf22cbd0" "The quick brown fox jumps over the lazy dog." + && test "d174ab98d277d9f5a5611c2c9f419d9f" + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + && test "9e107d9d372bb6826bd81d3542a419d6" + "The quick brown fox jumps over the lazy dog" + && test "e4d909c290d0fb1ca068ffaddf22cbd0" + "The quick brown fox jumps over the lazy dog." then printf "Test vectors passed.\n"; flush stdout; (* Benchmark *) diff --git a/testsuite/tests/lib-dynlink-csharp/entry.c b/testsuite/tests/lib-dynlink-csharp/entry.c index a82eb46f62..b5d11636ef 100755 --- a/testsuite/tests/lib-dynlink-csharp/entry.c +++ b/testsuite/tests/lib-dynlink-csharp/entry.c @@ -22,8 +22,8 @@ # define _DLLAPI __declspec(dllexport) # else # define _DLLAPI extern -# endif -# if defined(__MINGW32__) || defined(UNDER_CE) +# endif +# if defined(__MINGW32__) || defined(UNDER_CE) # define _CALLPROC # else # define _CALLPROC __stdcall diff --git a/testsuite/tests/lib-hashtbl/hfun.ml b/testsuite/tests/lib-hashtbl/hfun.ml index 0ff127579e..8a3c1cfc0d 100644 --- a/testsuite/tests/lib-hashtbl/hfun.ml +++ b/testsuite/tests/lib-hashtbl/hfun.ml @@ -35,7 +35,8 @@ let _ = printf "+infty\t\t%08x\n" (Hashtbl.hash infinity); printf "-infty\t\t%08x\n" (Hashtbl.hash neg_infinity); printf "NaN\t\t%08x\n" (Hashtbl.hash nan); - printf "NaN#2\t\t%08x\n" (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL)); + printf "NaN#2\t\t%08x\n" + (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL)); printf "NaN#3\t\t%08x\n" (Hashtbl.hash (0.0 /. 0.0)); printf "-- Native integers:\n"; diff --git a/testsuite/tests/lib-marshal/intext.ml b/testsuite/tests/lib-marshal/intext.ml index 41f24bb654..06f169e0bb 100644 --- a/testsuite/tests/lib-marshal/intext.ml +++ b/testsuite/tests/lib-marshal/intext.ml @@ -230,7 +230,8 @@ let test_string () = t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); let s = Marshal.to_string [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [] in - test 122 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); + test 122 + (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec big n = if n <= 0 then A else H(n, big(n-1)) in let s = Marshal.to_string (big 1000) [] in let rec check_big n t = @@ -317,7 +318,8 @@ let test_buffer () = t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); marshal_to_buffer s 0 512 [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] []; - test 222 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); + test 222 + (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec big n = if n <= 0 then A else H(n, big(n-1)) in test 223 (try marshal_to_buffer s 0 512 (big 1000) []; false diff --git a/testsuite/tests/lib-num/test_nats.ml b/testsuite/tests/lib-num/test_nats.ml index 7fc15b5171..541dd4c697 100644 --- a/testsuite/tests/lib-num/test_nats.ml +++ b/testsuite/tests/lib-num/test_nats.ml @@ -117,7 +117,10 @@ let set_mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3 = ignore (mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3) ;; -let s = "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333" in +let s = + "33333333333333333333333333333333333333333333333333333333333333333333\ + 33333333333333333333333333333333333333333333333333333333333333333333" +in test 21 equal_nat ( nat_of_string s, (let nat = make_nat 15 in diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml index 4f6626c111..3e55942a41 100644 --- a/testsuite/tests/lib-set/testset.ml +++ b/testsuite/tests/lib-set/testset.ml @@ -58,7 +58,8 @@ let test x s1 s2 = (S.elements s1 = List.filter (fun i -> S.mem i s1) testvals); checkbool "compare" - (normalize_cmp (S.compare s1 s2) = normalize_cmp (compare (S.elements s1) (S.elements s2))); + (normalize_cmp (S.compare s1 s2) + = normalize_cmp (compare (S.elements s1) (S.elements s2))); checkbool "equal" (S.equal s1 s2 = (S.elements s1 = S.elements s2)); diff --git a/testsuite/tests/lib-systhreads/testfork.precheck b/testsuite/tests/lib-systhreads/testfork.precheck index af81e807f7..f93abf1a69 100644 --- a/testsuite/tests/lib-systhreads/testfork.precheck +++ b/testsuite/tests/lib-systhreads/testfork.precheck @@ -14,4 +14,3 @@ case `sed -n -e '/OTHERLIBRARIES=/s// /p' ../../../config/Makefile` in *' unix '*) exit 0;; *) exit 3;; esac - diff --git a/testsuite/tests/lib-threads/test7.checker b/testsuite/tests/lib-threads/test7.checker index 55396e1382..4c4b2b4d69 100644 --- a/testsuite/tests/lib-threads/test7.checker +++ b/testsuite/tests/lib-threads/test7.checker @@ -10,4 +10,5 @@ # # ######################################################################### -test `grep -E '^-?[0123456789]+$' test7.result | wc -l` = `cat test7.result | wc -l` +test `grep -E '^-?[0123456789]+$' test7.result | wc -l` \ + = `cat test7.result | wc -l` diff --git a/testsuite/tests/lib-threads/testA.ml b/testsuite/tests/lib-threads/testA.ml index bdd33c3459..30efd6d398 100644 --- a/testsuite/tests/lib-threads/testA.ml +++ b/testsuite/tests/lib-threads/testA.ml @@ -26,8 +26,8 @@ let process id data = set_private_data data; Mutex.lock output_lock; print_int id; print_string " --> "; print_string(get_private_data()); - Mutex.unlock output_lock; - print_newline() + print_newline(); + Mutex.unlock output_lock let _ = let t1 = Thread.create (process 1) "un" in diff --git a/testsuite/tests/lib-threads/testsocket.ml b/testsuite/tests/lib-threads/testsocket.ml index ec16c058c2..4b41e0b937 100644 --- a/testsuite/tests/lib-threads/testsocket.ml +++ b/testsuite/tests/lib-threads/testsocket.ml @@ -20,7 +20,9 @@ let engine verbose number address = try while true do let s = input_line ic in - if verbose then (print_int number; print_string ">"; print_string s; print_newline()) + if verbose then begin + print_int number; print_string ">"; print_string s; print_newline() + end done; with End_of_file -> close_out oc; diff --git a/testsuite/tests/lib-threads/testsocket.precheck b/testsuite/tests/lib-threads/testsocket.precheck index 15ae35c52e..6d41158efb 100644 --- a/testsuite/tests/lib-threads/testsocket.precheck +++ b/testsuite/tests/lib-threads/testsocket.precheck @@ -20,4 +20,4 @@ # disable this test on Windows non-cygwin ports until we decide # how to fix PR#5325 and PR#5578 -$CANKILL
\ No newline at end of file +$CANKILL diff --git a/testsuite/tests/misc-kb/kb.mli b/testsuite/tests/misc-kb/kb.mli index c0578e56f2..246bc8198e 100644 --- a/testsuite/tests/misc-kb/kb.mli +++ b/testsuite/tests/misc-kb/kb.mli @@ -23,5 +23,7 @@ val deletion_message: rule -> unit val non_orientable: term * term -> unit val partition: ('a -> bool) -> 'a list -> 'a list * 'a list val get_rule: int -> rule list -> rule -val kb_completion: (term * term -> bool) -> int -> rule list -> (term * term) list -> int * int -> (term * term) list -> rule list +val kb_completion: + (term * term -> bool) -> int -> rule list -> (term * term) list + -> int * int -> (term * term) list -> rule list val kb_complete: (term * term -> bool) -> rule list -> rule list -> unit diff --git a/testsuite/tests/prim-bigstring/Makefile b/testsuite/tests/prim-bigstring/Makefile new file mode 100644 index 0000000000..379dba99c9 --- /dev/null +++ b/testsuite/tests/prim-bigstring/Makefile @@ -0,0 +1,8 @@ +BASEDIR=../.. +LIBRARIES=unix bigarray +ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \ + -I $(OTOPDIR)/otherlibs/bigarray +LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray + +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/prim-bigstring/bigstring_access.ml b/testsuite/tests/prim-bigstring/bigstring_access.ml new file mode 100644 index 0000000000..8fad87b151 --- /dev/null +++ b/testsuite/tests/prim-bigstring/bigstring_access.ml @@ -0,0 +1,102 @@ + +open Bigarray +type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t + +external caml_bigstring_get_16 : + bigstring -> int -> int = "%caml_bigstring_get16" +external caml_bigstring_get_32 : + bigstring -> int -> int32 = "%caml_bigstring_get32" +external caml_bigstring_get_64 : + bigstring -> int -> int64 = "%caml_bigstring_get64" + +external caml_bigstring_set_16 : + bigstring -> int -> int -> unit = "%caml_bigstring_set16" +external caml_bigstring_set_32 : + bigstring -> int -> int32 -> unit = "%caml_bigstring_set32" +external caml_bigstring_set_64 : + bigstring -> int -> int64 -> unit = "%caml_bigstring_set64" + +let bigstring_of_string s = + let a = Array1.create char c_layout (String.length s) in + for i = 0 to String.length s - 1 do + a.{i} <- s.[i] + done; + a + +let s = bigstring_of_string (String.make 10 '\x00') +let empty_s = bigstring_of_string "" + +let assert_bound_check2 f v1 v2 = + try + ignore(f v1 v2); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let assert_bound_check3 f v1 v2 v3 = + try + ignore(f v1 v2 v3); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let () = + assert_bound_check2 caml_bigstring_get_16 s (-1); + assert_bound_check2 caml_bigstring_get_16 s 9; + assert_bound_check2 caml_bigstring_get_32 s (-1); + assert_bound_check2 caml_bigstring_get_32 s 7; + assert_bound_check2 caml_bigstring_get_64 s (-1); + assert_bound_check2 caml_bigstring_get_64 s 3; + + assert_bound_check3 caml_bigstring_set_16 s (-1) 0; + assert_bound_check3 caml_bigstring_set_16 s 9 0; + assert_bound_check3 caml_bigstring_set_32 s (-1) 0l; + assert_bound_check3 caml_bigstring_set_32 s 7 0l; + assert_bound_check3 caml_bigstring_set_64 s (-1) 0L; + assert_bound_check3 caml_bigstring_set_64 s 3 0L; + + assert_bound_check2 caml_bigstring_get_16 empty_s 0; + assert_bound_check2 caml_bigstring_get_32 empty_s 0; + assert_bound_check2 caml_bigstring_get_64 empty_s 0; + + assert_bound_check3 caml_bigstring_set_16 empty_s 0 0; + assert_bound_check3 caml_bigstring_set_32 empty_s 0 0l; + assert_bound_check3 caml_bigstring_set_64 empty_s 0 0L + + + +let () = + caml_bigstring_set_16 s 0 0x1234; + Printf.printf "%x %x %x\n%!" + (caml_bigstring_get_16 s 0) + (caml_bigstring_get_16 s 1) + (caml_bigstring_get_16 s 2); + caml_bigstring_set_16 s 0 0xFEDC; + Printf.printf "%x %x %x\n%!" + (caml_bigstring_get_16 s 0) + (caml_bigstring_get_16 s 1) + (caml_bigstring_get_16 s 2) + +let () = + caml_bigstring_set_32 s 0 0x12345678l; + Printf.printf "%lx %lx %lx\n%!" + (caml_bigstring_get_32 s 0) + (caml_bigstring_get_32 s 1) + (caml_bigstring_get_32 s 2); + caml_bigstring_set_32 s 0 0xFEDCBA09l; + Printf.printf "%lx %lx %lx\n%!" + (caml_bigstring_get_32 s 0) + (caml_bigstring_get_32 s 1) + (caml_bigstring_get_32 s 2) + +let () = + caml_bigstring_set_64 s 0 0x1234567890ABCDEFL; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_bigstring_get_64 s 0) + (caml_bigstring_get_64 s 1) + (caml_bigstring_get_64 s 2); + caml_bigstring_set_64 s 0 0xFEDCBA0987654321L; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_bigstring_get_64 s 0) + (caml_bigstring_get_64 s 1) + (caml_bigstring_get_64 s 2) diff --git a/testsuite/tests/prim-bigstring/bigstring_access.reference b/testsuite/tests/prim-bigstring/bigstring_access.reference new file mode 100644 index 0000000000..22b25addf3 --- /dev/null +++ b/testsuite/tests/prim-bigstring/bigstring_access.reference @@ -0,0 +1,6 @@ +1234 12 0 +fedc fe 0 +12345678 123456 1234 +fedcba09 fedcba fedc +1234567890abcdef 1234567890abcd 1234567890ab +fedcba0987654321 fedcba09876543 fedcba098765 diff --git a/testsuite/tests/prim-bigstring/string_access.ml b/testsuite/tests/prim-bigstring/string_access.ml new file mode 100644 index 0000000000..3afcc6c552 --- /dev/null +++ b/testsuite/tests/prim-bigstring/string_access.ml @@ -0,0 +1,89 @@ + +external caml_string_get_16 : string -> int -> int = "%caml_string_get16" +external caml_string_get_32 : string -> int -> int32 = "%caml_string_get32" +external caml_string_get_64 : string -> int -> int64 = "%caml_string_get64" + +external caml_string_set_16 : string -> int -> int -> unit = + "%caml_string_set16" +external caml_string_set_32 : string -> int -> int32 -> unit = + "%caml_string_set32" +external caml_string_set_64 : string -> int -> int64 -> unit = + "%caml_string_set64" + +let s = String.make 10 '\x00' +let empty_s = "" + +let assert_bound_check2 f v1 v2 = + try + ignore(f v1 v2); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let assert_bound_check3 f v1 v2 v3 = + try + ignore(f v1 v2 v3); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let () = + assert_bound_check2 caml_string_get_16 s (-1); + assert_bound_check2 caml_string_get_16 s 9; + assert_bound_check2 caml_string_get_32 s (-1); + assert_bound_check2 caml_string_get_32 s 7; + assert_bound_check2 caml_string_get_64 s (-1); + assert_bound_check2 caml_string_get_64 s 3; + + assert_bound_check3 caml_string_set_16 s (-1) 0; + assert_bound_check3 caml_string_set_16 s 9 0; + assert_bound_check3 caml_string_set_32 s (-1) 0l; + assert_bound_check3 caml_string_set_32 s 7 0l; + assert_bound_check3 caml_string_set_64 s (-1) 0L; + assert_bound_check3 caml_string_set_64 s 3 0L; + + assert_bound_check2 caml_string_get_16 empty_s 0; + assert_bound_check2 caml_string_get_32 empty_s 0; + assert_bound_check2 caml_string_get_64 empty_s 0; + + assert_bound_check3 caml_string_set_16 empty_s 0 0; + assert_bound_check3 caml_string_set_32 empty_s 0 0l; + assert_bound_check3 caml_string_set_64 empty_s 0 0L + + + +let () = + caml_string_set_16 s 0 0x1234; + Printf.printf "%x %x %x\n%!" + (caml_string_get_16 s 0) + (caml_string_get_16 s 1) + (caml_string_get_16 s 2); + caml_string_set_16 s 0 0xFEDC; + Printf.printf "%x %x %x\n%!" + (caml_string_get_16 s 0) + (caml_string_get_16 s 1) + (caml_string_get_16 s 2) + +let () = + caml_string_set_32 s 0 0x12345678l; + Printf.printf "%lx %lx %lx\n%!" + (caml_string_get_32 s 0) + (caml_string_get_32 s 1) + (caml_string_get_32 s 2); + caml_string_set_32 s 0 0xFEDCBA09l; + Printf.printf "%lx %lx %lx\n%!" + (caml_string_get_32 s 0) + (caml_string_get_32 s 1) + (caml_string_get_32 s 2) + +let () = + caml_string_set_64 s 0 0x1234567890ABCDEFL; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_string_get_64 s 0) + (caml_string_get_64 s 1) + (caml_string_get_64 s 2); + caml_string_set_64 s 0 0xFEDCBA0987654321L; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_string_get_64 s 0) + (caml_string_get_64 s 1) + (caml_string_get_64 s 2) diff --git a/testsuite/tests/prim-bigstring/string_access.reference b/testsuite/tests/prim-bigstring/string_access.reference new file mode 100644 index 0000000000..22b25addf3 --- /dev/null +++ b/testsuite/tests/prim-bigstring/string_access.reference @@ -0,0 +1,6 @@ +1234 12 0 +fedc fe 0 +12345678 123456 1234 +fedcba09 fedcba fedc +1234567890abcdef 1234567890abcd 1234567890ab +fedcba0987654321 fedcba09876543 fedcba098765 diff --git a/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker index 893d1efd94..b4f86ac69d 100644 --- a/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker +++ b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker @@ -11,4 +11,3 @@ ######################################################################### $DIFF stackoverflow.bytecode.reference stackoverflow.bytecode.result - diff --git a/testsuite/tests/runtime-errors/stackoverflow.native.checker b/testsuite/tests/runtime-errors/stackoverflow.native.checker index ac12dd3f84..26c2ccf14e 100644 --- a/testsuite/tests/runtime-errors/stackoverflow.native.checker +++ b/testsuite/tests/runtime-errors/stackoverflow.native.checker @@ -11,4 +11,3 @@ ######################################################################### $DIFF stackoverflow.native.reference stackoverflow.native.result - diff --git a/testsuite/tests/runtime-errors/syserror.bytecode.checker b/testsuite/tests/runtime-errors/syserror.bytecode.checker index ed2d20950d..a1cb88a527 100644 --- a/testsuite/tests/runtime-errors/syserror.bytecode.checker +++ b/testsuite/tests/runtime-errors/syserror.bytecode.checker @@ -11,6 +11,3 @@ ######################################################################### grep 'Fatal error: exception Sys_error' syserror.bytecode.result >/dev/null - - - diff --git a/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml index 1a5995728c..d5dd517a5b 100644 --- a/testsuite/tests/tool-lexyacc/lexgen.ml +++ b/testsuite/tests/tool-lexyacc/lexgen.ml @@ -55,7 +55,9 @@ let rec print_regexp = function | Chars n -> prerr_string "Chars "; prerr_int n | Action n -> prerr_string "Action "; prerr_int n | Seq(r1,r2) -> print_regexp r1; prerr_string "; "; print_regexp r2 - | Alt(r1,r2) -> prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; prerr_string ")" + | Alt(r1,r2) -> + prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; + prerr_string ")" | Star r -> prerr_string "("; print_regexp r; prerr_string ")*" ***) @@ -248,7 +250,10 @@ let make_dfa lexdef = let (chars, name_regexp_list, actions) = encode_lexdef lexdef in (** - List.iter (fun (name, regexp) -> prerr_string name; prerr_string " = "; print_regexp regexp; prerr_newline()) name_regexp_list; + List.iter (fun (name, regexp) -> + prerr_string name; prerr_string " = "; print_regexp regexp; + prerr_newline()) + name_regexp_list; **) let follow = followpos (Array.length chars) name_regexp_list in diff --git a/testsuite/tests/typing-fstclassmod/Makefile b/testsuite/tests/typing-fstclassmod/Makefile index e854696f45..e779183677 100644 --- a/testsuite/tests/typing-fstclassmod/Makefile +++ b/testsuite/tests/typing-fstclassmod/Makefile @@ -13,7 +13,7 @@ BASEDIR=../.. #MODULES= MAIN_MODULE=fstclassmod -ADD_COMPFLAGS=-w a +ADD_COMPFLAGS=-w A -warn-error A include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.ml b/testsuite/tests/typing-fstclassmod/fstclassmod.ml index 82af377bec..bc8d66e51c 100644 --- a/testsuite/tests/typing-fstclassmod/fstclassmod.ml +++ b/testsuite/tests/typing-fstclassmod/fstclassmod.ml @@ -146,11 +146,20 @@ let () = module type S1 = sig end module type S2 = S1 -let f (x : (module S1)) : (module S2) = x +let _f (x : (module S1)) : (module S2) = x module X = struct module type S end module Y = struct include X end -let f (x : (module X.S)) : (module Y.S) = x +let _f (x : (module X.S)) : (module Y.S) = x + +(* PR#6194, main example *) +module type S3 = sig val x : bool end;; +let f = function + | Some (module M : S3) when M.x ->1 + | Some _ -> 2 + | None -> 3 +;; +print_endline (string_of_int (f (Some (module struct let x = false end))));; diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.reference b/testsuite/tests/typing-fstclassmod/fstclassmod.reference index 59c7aa116c..ec517d7893 100644 --- a/testsuite/tests/typing-fstclassmod/fstclassmod.reference +++ b/testsuite/tests/typing-fstclassmod/fstclassmod.reference @@ -4,3 +4,4 @@ abc/def/xyz xyz/def/abc XXXXXXXX 10 (123,("A",456)) +2 diff --git a/testsuite/tests/typing-gadts/pr5948.ml b/testsuite/tests/typing-gadts/pr5948.ml index 8ba45d2dff..0acc90868b 100644 --- a/testsuite/tests/typing-gadts/pr5948.ml +++ b/testsuite/tests/typing-gadts/pr5948.ml @@ -1,6 +1,6 @@ type tag = [`TagA | `TagB | `TagC];; -type 'a poly = +type 'a poly = AandBTags : [< `TagA of int | `TagB ] poly | ATag : [< `TagA of int] poly (* constraint 'a = [< `TagA of int | `TagB] *) @@ -10,17 +10,17 @@ let intA = function `TagA i -> i let intB = function `TagB -> 4 ;; -let intAorB = function +let intAorB = function `TagA i -> i | `TagB -> 4 ;; -type _ wrapPoly = +type _ wrapPoly = WrapPoly : 'a poly -> ([< `TagA of int | `TagB] as 'a) wrapPoly ;; let example6 : type a. a wrapPoly -> (a -> int) = - fun w -> + fun w -> match w with | WrapPoly ATag -> intA | WrapPoly _ -> intA (* This should not be allowed *) diff --git a/testsuite/tests/typing-gadts/pr5985.ml b/testsuite/tests/typing-gadts/pr5985.ml index 6d0bbcee7b..23902add37 100644 --- a/testsuite/tests/typing-gadts/pr5985.ml +++ b/testsuite/tests/typing-gadts/pr5985.ml @@ -29,7 +29,7 @@ end;; (* fail *) (* Another (more direct) instance using polymorphic variants *) (* PR#6275 *) type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *) -let magic (x : int) : bool = +let magic (x : int) : bool = let A x = A x in x;; (* fail *) type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *) diff --git a/testsuite/tests/typing-gadts/pr6163.ml b/testsuite/tests/typing-gadts/pr6163.ml index e9646196e7..ad5e8eda73 100644 --- a/testsuite/tests/typing-gadts/pr6163.ml +++ b/testsuite/tests/typing-gadts/pr6163.ml @@ -1,4 +1,4 @@ -type _ nat = +type _ nat = Zero : [`Zero] nat | Succ : 'a nat -> [`Succ of 'a] nat;; type 'a pre_nat = [`Zero | `Succ of 'a];; diff --git a/testsuite/tests/typing-labels/mixin2.ml b/testsuite/tests/typing-labels/mixin2.ml index 8a5498fa33..fd2b289796 100644 --- a/testsuite/tests/typing-labels/mixin2.ml +++ b/testsuite/tests/typing-labels/mixin2.ml @@ -182,7 +182,9 @@ let rec print = function let () = let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in - let e3 = lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in + let e3 = + lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) + in print e1; print_newline (); print e2; print_newline (); print e3; print_newline () diff --git a/testsuite/tests/typing-labels/mixin3.ml b/testsuite/tests/typing-labels/mixin3.ml index 0b9db24281..5b987e8198 100644 --- a/testsuite/tests/typing-labels/mixin3.ml +++ b/testsuite/tests/typing-labels/mixin3.ml @@ -176,7 +176,9 @@ let rec print = function let () = let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in - let e3 = lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in + let e3 = + lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) + in print e1; print_newline (); print e2; print_newline (); print e3; print_newline () diff --git a/testsuite/tests/typing-misc/labels.ml b/testsuite/tests/typing-misc/labels.ml index b0f0229a6b..2d4b9d19d8 100644 --- a/testsuite/tests/typing-misc/labels.ml +++ b/testsuite/tests/typing-misc/labels.ml @@ -1,4 +1,11 @@ (* PR#5835 *) - let f ~x = x + 1;; f ?x:0;; + +(* PR#6352 *) +let foo (f : unit -> unit) = ();; +let g ?x () = ();; +foo ((); g);; + +(* PR#5748 *) +foo (fun ?opt () -> ()) ;; (* fails *) diff --git a/testsuite/tests/typing-misc/labels.ml.principal.reference b/testsuite/tests/typing-misc/labels.ml.principal.reference index b76dcddc51..2f21fd3f0b 100644 --- a/testsuite/tests/typing-misc/labels.ml.principal.reference +++ b/testsuite/tests/typing-misc/labels.ml.principal.reference @@ -1,8 +1,16 @@ -# val f : x:int -> int = <fun> +# val f : x:int -> int = <fun> # Characters 5-6: f ?x:0;; ^ Warning 43: the label x is not optional. - : int = 1 +# val foo : (unit -> unit) -> unit = <fun> +# val g : ?x:'a -> unit -> unit = <fun> +# - : unit = () +# Characters 19-38: + foo (fun ?opt () -> ()) ;; (* fails *) + ^^^^^^^^^^^^^^^^^^^ +Error: This function should have type unit -> unit + but its first argument is labelled ~?opt # diff --git a/testsuite/tests/typing-misc/labels.ml.reference b/testsuite/tests/typing-misc/labels.ml.reference index b76dcddc51..2f21fd3f0b 100644 --- a/testsuite/tests/typing-misc/labels.ml.reference +++ b/testsuite/tests/typing-misc/labels.ml.reference @@ -1,8 +1,16 @@ -# val f : x:int -> int = <fun> +# val f : x:int -> int = <fun> # Characters 5-6: f ?x:0;; ^ Warning 43: the label x is not optional. - : int = 1 +# val foo : (unit -> unit) -> unit = <fun> +# val g : ?x:'a -> unit -> unit = <fun> +# - : unit = () +# Characters 19-38: + foo (fun ?opt () -> ()) ;; (* fails *) + ^^^^^^^^^^^^^^^^^^^ +Error: This function should have type unit -> unit + but its first argument is labelled ~?opt # diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index 0b7e7ae2b0..4a4a1a2d69 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -112,7 +112,7 @@ let f (x : t) : T.t = x ;; module A = struct module B = struct type t let compare x y = 0 end module S = Set.Make(B) - let empty = S.empty + let empty = S.empty end module A1 = A;; A1.empty = A.empty;; @@ -192,3 +192,9 @@ module M = struct end end;; module type S = module type of M ;; + +(* PR#6365 *) +module type S = sig module M : sig type t val x : t end end;; +module H = struct type t = A let x = A end;; +module H' = H;; +module type S' = S with module M = H';; (* shouldn't introduce an alias *) diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference index 730252b580..a024731abe 100644 --- a/testsuite/tests/typing-modules/aliases.ml.reference +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -347,4 +347,8 @@ Error: In this `with' constraint, the new definition of I module Q : sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end end +# module type S = sig module M : sig type t val x : t end end +# module H : sig type t = A val x : t end +# module H' = H +# module type S' = sig module M : sig type t = H.t = A val x : t end end # diff --git a/testsuite/tests/typing-modules/generative.ml b/testsuite/tests/typing-modules/generative.ml index 2768aba619..dc5bf52898 100644 --- a/testsuite/tests/typing-modules/generative.ml +++ b/testsuite/tests/typing-modules/generative.ml @@ -27,7 +27,8 @@ module F4 : functor (X : sig end) -> sig end = F3;; (* fail *) (* tests for shortened functor notation () *) module X (X: sig end) (Y: sig end) = functor (Z: sig end) -> struct end;; -module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) -> struct end;; +module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) -> + struct end;; module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;; module GZ : functor (X: sig end) () (Z: sig end) -> sig end = functor (X: sig end) () (Z: sig end) -> struct end;; diff --git a/testsuite/tests/typing-modules/generative.ml.reference b/testsuite/tests/typing-modules/generative.ml.reference index 19aaa12842..a6aa100266 100644 --- a/testsuite/tests/typing-modules/generative.ml.reference +++ b/testsuite/tests/typing-modules/generative.ml.reference @@ -38,7 +38,7 @@ Error: Signature mismatch: is not included in functor (X : sig end) -> sig end # module X : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end -# module Y : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end +# module Y : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end # module Z : functor (_ : sig end) (_ : sig end) (_ : sig end) -> sig end # module GZ : functor (X : sig end) () (Z : sig end) -> sig end # diff --git a/testsuite/tests/typing-warnings/coercions.ml b/testsuite/tests/typing-warnings/coercions.ml new file mode 100644 index 0000000000..1ca390b28e --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml @@ -0,0 +1,5 @@ +(* comment 9644 of PR#6000 *) + +fun b -> if b then format_of_string "x" else "y";; +fun b -> if b then "x" else format_of_string "y";; +fun b -> (if b then "x" else "y" : (_,_,_) format);; diff --git a/testsuite/tests/typing-warnings/coercions.ml.principal.reference b/testsuite/tests/typing-warnings/coercions.ml.principal.reference new file mode 100644 index 0000000000..d950e231fc --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml.principal.reference @@ -0,0 +1,13 @@ + +# Characters 76-79: + fun b -> if b then format_of_string "x" else "y";; + ^^^ +Warning 18: this coercion to format6 is not principal. +- : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun> +# Characters 28-48: + fun b -> if b then "x" else format_of_string "y";; + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type ('a, 'b, 'c, 'd, 'd, 'a) format6 + but an expression was expected of type string +# - : bool -> ('a, 'b, 'a) format = <fun> +# diff --git a/testsuite/tests/typing-warnings/coercions.ml.reference b/testsuite/tests/typing-warnings/coercions.ml.reference new file mode 100644 index 0000000000..2ab458b682 --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml.reference @@ -0,0 +1,9 @@ + +# - : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun> +# Characters 28-48: + fun b -> if b then "x" else format_of_string "y";; + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type ('a, 'b, 'c, 'd, 'd, 'a) format6 + but an expression was expected of type string +# - : bool -> ('a, 'b, 'a) format = <fun> +# diff --git a/tools/.ignore b/tools/.ignore index ce14846de2..94fac02fbc 100644 --- a/tools/.ignore +++ b/tools/.ignore @@ -18,11 +18,10 @@ keywords lexer299.ml ocaml299to3 ocamlmklib -ocamlmklib.ml +ocamlmklibconfig.ml lexer301.ml scrapelabels addlabels -myocamlbuild_config.ml objinfo_helper read_cmt read_cmt.opt diff --git a/tools/Makefile b/tools/Makefile index e2f3cb26e7..b5cc10109b 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -19,7 +19,7 @@ ocamlmktop: ocamlmktop.tpl ../config/Makefile chmod +x ocamlmktop install:: - cp ocamlmktop $(BINDIR) + cp ocamlmktop $(INSTALL_BINDIR) clean:: rm -f ocamlmktop diff --git a/tools/Makefile.nt b/tools/Makefile.nt index 052af81c22..ed9b35946d 100644 --- a/tools/Makefile.nt +++ b/tools/Makefile.nt @@ -21,7 +21,7 @@ ocamlmktop: $(OCAMLMKTOP) $(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP) install:: - cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE) + cp ocamlmktop $(INSTALL_BINDIR)/ocamlmktop$(EXE) clean:: rm -f ocamlmktop$(EXE) diff --git a/tools/Makefile.shared b/tools/Makefile.shared index 39be1db4e9..6b33a5b047 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -54,10 +54,14 @@ clean:: if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi rm -f ocamldep.opt + +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install:: - cp ocamldep $(BINDIR)/ocamldep$(EXE) + cp ocamldep $(INSTALL_BINDIR)/ocamldep$(EXE) if test -f ocamldep.opt; \ - then cp ocamldep.opt $(BINDIR)/ocamldep.opt$(EXE); else :; fi + then cp ocamldep.opt $(INSTALL_BINDIR)/ocamldep.opt$(EXE); else :; fi # The profiler @@ -79,13 +83,13 @@ ocamloptp: ocamloptp.cmo opt:: profiling.cmx install:: - cp ocamlprof $(BINDIR)/ocamlprof$(EXE) - cp ocamlcp $(BINDIR)/ocamlcp$(EXE) - cp ocamloptp $(BINDIR)/ocamloptp$(EXE) - cp profiling.cmi profiling.cmo $(LIBDIR) + cp ocamlprof $(INSTALL_BINDIR)/ocamlprof$(EXE) + cp ocamlcp $(INSTALL_BINDIR)/ocamlcp$(EXE) + cp ocamloptp $(INSTALL_BINDIR)/ocamloptp$(EXE) + cp profiling.cmi profiling.cmo $(INSTALL_LIBDIR) installopt:: - cp profiling.cmx profiling.o $(LIBDIR) + cp profiling.cmx profiling.$(O) $(INSTALL_LIBDIR) clean:: rm -f ocamlprof ocamlcp ocamloptp @@ -97,7 +101,7 @@ ocamlmklib: ocamlmklibconfig.cmo ocamlmklib.cmo $(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklibconfig.cmo ocamlmklib.cmo install:: - cp ocamlmklib $(BINDIR)/ocamlmklib$(EXE) + cp ocamlmklib $(INSTALL_BINDIR)/ocamlmklib$(EXE) clean:: rm -f ocamlmklib @@ -132,7 +136,7 @@ lexer299.ml: lexer299.mll $(CAMLLEX) lexer299.mll #install:: -# cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) +# cp ocaml299to3 $(INSTALL_BINDIR)/ocaml299to3$(EXE) clean:: rm -f ocaml299to3 lexer299.ml @@ -148,7 +152,7 @@ lexer301.ml: lexer301.mll $(CAMLLEX) lexer301.mll #install:: -# cp scrapelabels $(LIBDIR) +# cp scrapelabels $(INSTALL_LIBDIR) clean:: rm -f scrapelabels lexer301.ml @@ -164,7 +168,7 @@ addlabels: addlabels.cmo $(ADDLABELS_IMPORTS) addlabels.cmo #install:: -# cp addlabels $(LIBDIR) +# cp addlabels $(INSTALL_LIBDIR) clean:: rm -f addlabels @@ -285,8 +289,8 @@ objinfo: objinfo_helper$(EXE) $(OBJINFO) $(CAMLC) -o objinfo $(OBJINFO) install:: - cp objinfo $(BINDIR)/ocamlobjinfo$(EXE) - cp objinfo_helper$(EXE) $(LIBDIR)/objinfo_helper$(EXE) + cp objinfo $(INSTALL_BINDIR)/ocamlobjinfo$(EXE) + cp objinfo_helper$(EXE) $(INSTALL_LIBDIR)/objinfo_helper$(EXE) clean:: rm -f objinfo objinfo_helper$(EXE) diff --git a/tools/check-typo b/tools/check-typo index 05c7c68c07..93814131e5 100755 --- a/tools/check-typo +++ b/tools/check-typo @@ -34,6 +34,10 @@ # Built-in exceptions: # - Any binary file (i.e. with svn:mime-type = application/octet-stream) # is automatically exempt from all the rules. +# - Any file whose name matches one of the following patterns is +# automatically exempt from all rules +# *.reference +# */reference # - Any file whose name begins with "Makefile" is automatically exempt # from the "tabs" rule. # - Any file whose name matches one of the following patterns is @@ -45,11 +49,6 @@ # *.mltop # *.odocl # *.clib -# *.reference -# */reference -# - Any file whose name matches one of the following patterns is -# automatically exempt from the "long-line" rule. -# *.reference # ASCII characters are bytes from 0 to 127. Any other byte is # flagged as a non-ASCII character. @@ -138,10 +137,7 @@ IGNORE_DIRS=" case "$f" in */.depend*|*/.ignore) h;; *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) h;; - *.reference|*/reference) h;; - esac - case "$f" in - *.reference) rules="long-line,$rules";; + *.reference|*/reference) continue;; esac (cat "$f"; echo) \ diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index db8494cc26..f1255e9cd2 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -493,6 +493,7 @@ let dump_obj filename ic = if cu.cu_debug > 0 then begin seek_in ic cu.cu_debug; let evl = (input_value ic : debug_event list) in + ignore (input_value ic); (* Skip the list of absolute directory names *) record_events 0 evl end; seek_in ic cu.cu_pos; @@ -531,6 +532,7 @@ let dump_exe ic = for _i = 1 to num_eventlists do let orig = input_binary_int ic in let evl = (input_value ic : debug_event list) in + ignore (input_value ic); (* Skip the list of absolute directory names *) record_events orig evl done with Not_found -> () diff --git a/tools/eqparsetree.ml b/tools/eqparsetree.ml index 332efa3e14..128453e0c3 100644 --- a/tools/eqparsetree.ml +++ b/tools/eqparsetree.ml @@ -120,7 +120,7 @@ module Asttypes = struct (('all_a0 loc) * ('all_a0 loc)) -> 'result = fun mf_a ({ txt = a0; loc = a1 }, { txt = b0; loc = b1 }) -> (mf_a (a0, b0)) && (Location.eq_t (a1, b1)) - + end let rec eq_row_field : (row_field * row_field) -> 'result = @@ -185,7 +185,7 @@ and eq_core_type : (core_type * core_type) -> 'result = ({ ptyp_desc = a0; ptyp_loc = a1 }, { ptyp_desc = b0; ptyp_loc = b1 }) -> (eq_core_type_desc (a0, b0)) && (Location.eq_t (a1, b1)) - + let eq_class_infos : 'all_a0. (('all_a0 * 'all_a0) -> 'result) -> @@ -221,7 +221,7 @@ let eq_class_infos : (eq_bool (a0, b0)) && (eq_bool (a1, b1))) (a4, b4))) && (Location.eq_t (a5, b5)) - + let rec eq_pattern_desc : (pattern_desc * pattern_desc) -> 'result = function | (Ppat_any, Ppat_any) -> true @@ -259,7 +259,7 @@ and eq_pattern : (pattern * pattern) -> 'result = ({ ppat_desc = a0; ppat_loc = a1 }, { ppat_desc = b0; ppat_loc = b1 }) -> (eq_pattern_desc (a0, b0)) && (Location.eq_t (a1, b1)) - + let rec eq_structure_item_desc : (structure_item_desc * structure_item_desc) -> 'result = function @@ -760,7 +760,7 @@ and eq_expression : (expression * expression) -> 'result = ({ pexp_desc = a0; pexp_loc = a1 }, { pexp_desc = b0; pexp_loc = b1 }) -> (eq_expression_desc (a0, b0)) && (Location.eq_t (a1, b1)) - + let rec eq_directive_argument : (directive_argument * directive_argument) -> 'result = function diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml index c0c5eb09dc..0ff9f3df77 100644 --- a/tools/read_cmt.ml +++ b/tools/read_cmt.ml @@ -16,43 +16,49 @@ let print_info_arg = ref false let target_filename = ref None let arg_list = [ - "-o", Arg.String (fun s -> - target_filename := Some s - ), " FILE (or -) : dump to file FILE (or stdout)"; + "-o", Arg.String (fun s -> target_filename := Some s), + " FILE (or -) : dump to file FILE (or stdout)"; "-annot", Arg.Set gen_annot, " : generate the corresponding .annot file"; - "-src", Arg.Set gen_ml, " : generate an equivalent of the original source file (without comments) from a .cmt or a .cmti file"; + "-src", Arg.Set gen_ml, + " : convert .cmt or .cmti back to source code (without comments)"; "-info", Arg.Set print_info_arg, " : print information on the file"; ] -let arg_usage = "read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information" +let arg_usage = + "read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information" let print_info cmt = let open Cmt_format in Printf.printf "module name: %s\n" cmt.cmt_modname; begin match cmt.cmt_annots with - Packed (_, list) -> Printf.printf "pack: %s\n" (String.concat " " list) + Packed (_, list) -> + Printf.printf "pack: %s\n" (String.concat " " list) | Implementation _ -> Printf.printf "kind: implementation\n" | Interface _ -> Printf.printf "kind: interface\n" - | Partial_implementation _ -> Printf.printf "kind: implementation with errors\n" + | Partial_implementation _ -> + Printf.printf "kind: implementation with errors\n" | Partial_interface _ -> Printf.printf "kind: interface with errors\n" end; - Printf.printf "command: %s\n" (String.concat " " (Array.to_list cmt.cmt_args)); + Printf.printf "command: %s\n" + (String.concat " " (Array.to_list cmt.cmt_args)); begin match cmt.cmt_sourcefile with None -> () | Some name -> Printf.printf "sourcefile: %s\n" name; end; Printf.printf "build directory: %s\n" cmt.cmt_builddir; - List.iter (fun dir -> Printf.printf "load path: %s\n%!" dir) cmt.cmt_loadpath; + List.iter (Printf.printf "load path: %s\n%!") cmt.cmt_loadpath; begin match cmt.cmt_source_digest with None -> () - | Some digest -> Printf.printf "source digest: %s\n" (Digest.to_hex digest); + | Some digest -> + Printf.printf "source digest: %s\n" (Digest.to_hex digest); end; begin match cmt.cmt_interface_digest with None -> () - | Some digest -> Printf.printf "interface digest: %s\n" (Digest.to_hex digest); + | Some digest -> + Printf.printf "interface digest: %s\n" (Digest.to_hex digest); end; List.iter (fun (name, digest) -> Printf.printf "import: %s %s\n" name (Digest.to_hex digest); @@ -74,7 +80,8 @@ let _ = if !gen_ml then Cmt2annot.gen_ml !target_filename filename cmt; if !print_info_arg || not (!gen_ml || !gen_annot) then print_info cmt; end else begin - Printf.fprintf stderr "Error: the file must have an extension in .cmt or .cmti.\n%!"; + Printf.fprintf stderr + "Error: the file's extension must be .cmt or .cmti.\n%!"; Arg.usage arg_list arg_usage end ) arg_usage diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 931e8cee58..84877bfb29 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -62,7 +62,8 @@ and untype_structure_item item = | Tstr_recmodule list -> Pstr_recmodule (List.map untype_module_binding list) | Tstr_modtype mtd -> - Pstr_modtype {pmtd_name=mtd.mtd_name; pmtd_type=option untype_module_type mtd.mtd_type; + Pstr_modtype {pmtd_name=mtd.mtd_name; + pmtd_type=option untype_module_type mtd.mtd_type; pmtd_loc=mtd.mtd_loc;pmtd_attributes=mtd.mtd_attributes;} | Tstr_open (ovf, _path, lid, attrs) -> Pstr_open (ovf, lid, attrs) | Tstr_class list -> @@ -197,7 +198,8 @@ and untype_pattern pat = | Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2) | Tpat_lazy p -> Ppat_lazy (untype_pattern p) in - Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc (* todo: fix attributes on extras *) + Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc + (* todo: fix attributes on extras *) and untype_extra (extra, loc, attrs) sexp = let desc = @@ -337,7 +339,8 @@ and untype_signature_item item = | Tsig_exception decl -> Psig_exception (untype_constructor_declaration decl) | Tsig_module md -> - Psig_module {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type; + Psig_module {pmd_name = md.md_name; + pmd_type = untype_module_type md.md_type; pmd_attributes = md.md_attributes; pmd_loc = md.md_loc; } | Tsig_recmodule list -> @@ -345,10 +348,12 @@ and untype_signature_item item = {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type; pmd_attributes = md.md_attributes; pmd_loc = md.md_loc}) list) | Tsig_modtype mtd -> - Psig_modtype {pmtd_name=mtd.mtd_name; pmtd_type=option untype_module_type mtd.mtd_type; + Psig_modtype {pmtd_name=mtd.mtd_name; + pmtd_type=option untype_module_type mtd.mtd_type; pmtd_attributes=mtd.mtd_attributes; pmtd_loc=mtd.mtd_loc} | Tsig_open (ovf, _path, lid, attrs) -> Psig_open (ovf, lid, attrs) - | Tsig_include (mty, _, attrs) -> Psig_include (untype_module_type mty, attrs) + | Tsig_include (mty, _, attrs) -> + Psig_include (untype_module_type mty, attrs) | Tsig_class list -> Psig_class (List.map untype_class_description list) | Tsig_class_type list -> diff --git a/tools/untypeast.mli b/tools/untypeast.mli index 0e0351ef9a..efd0a031d5 100644 --- a/tools/untypeast.mli +++ b/tools/untypeast.mli @@ -13,7 +13,8 @@ val untype_structure : Typedtree.structure -> Parsetree.structure val untype_signature : Typedtree.signature -> Parsetree.signature val untype_expression : Typedtree.expression -> Parsetree.expression -val untype_type_declaration : Typedtree.type_declaration -> Parsetree.type_declaration +val untype_type_declaration : + Typedtree.type_declaration -> Parsetree.type_declaration val untype_module_type : Typedtree.module_type -> Parsetree.module_type val lident_of_path : Path.t -> Longident.t diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index c2e3791f07..29751de8f7 100644 --- a/typing/cmt_format.ml +++ b/typing/cmt_format.ml @@ -239,4 +239,3 @@ let save_cmt filename modname binary_annots sourcefile initial_env sg = close_out oc; end; clear () - diff --git a/typing/cmt_format.mli b/typing/cmt_format.mli index 30493063dc..ba264a314d 100644 --- a/typing/cmt_format.mli +++ b/typing/cmt_format.mli @@ -102,7 +102,8 @@ val add_saved_type : binary_part -> unit val get_saved_types : unit -> binary_part list val set_saved_types : binary_part list -> unit -val record_value_dependency: Types.value_description -> Types.value_description -> unit +val record_value_dependency: + Types.value_description -> Types.value_description -> unit (* diff --git a/typing/ctype.ml b/typing/ctype.ml index afe92e1599..4989aa7ced 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -1980,6 +1980,18 @@ let non_aliasable p decl = (* in_pervasives p || (subsumed by in_current_module) *) in_current_module p && decl.type_newtype_level = None +(* Check for datatypes carefully; see PR#6348 *) +let rec expands_to_datatype env ty = + let ty = repr ty in + match ty.desc with + Tconstr (p, _, _) -> + begin try + is_datatype (Env.find_type p env) || + expands_to_datatype env (try_expand_once env ty) + with Not_found | Cannot_expand -> false + end + | _ -> false + (* mcomp type_pairs subst env t1 t2 does not raise an exception if it is possible that t1 and t2 are actually equal, assuming the types in type_pairs are equal and @@ -2264,7 +2276,7 @@ let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 = let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2 and ntl1 = complete_type_list env n2 lv2 (Mty_ident p1) n1 tl1 in unify_list (List.map snd ntl1) (List.map snd ntl2); - if eq_package_path env p1 p2 + if eq_package_path env p1 p2 || !package_subtype env p1 n1 tl1 p2 n2 tl2 && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found @@ -2417,7 +2429,8 @@ and unify3 env t1 t1' t2 t2' = | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> if !umode = Expression || not !generate_equations || in_current_module p1 (* || in_pervasives p1 *) - || try is_datatype (Env.find_type p1 !env) with Not_found -> false + || List.exists (expands_to_datatype !env) [t1'; t1; t2] + (*try is_datatype (Env.find_type p1 !env) with Not_found -> false*) then unify_list env tl1 tl2 else diff --git a/typing/env.ml b/typing/env.ml index 41b2e4f9fa..f5c3abc229 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1020,11 +1020,11 @@ let rec scrape_alias env ?path mty = begin try scrape_alias env (find_module path env).md_type ~path with Not_found -> - Location.prerr_warning Location.none + Location.prerr_warning Location.none (Warnings.Deprecated ("module " ^ Path.name path ^ " cannot be accessed")); mty - end + end | mty, Some path -> !strengthen env mty path | _ -> mty @@ -1781,7 +1781,8 @@ open Format let report_error ppf = function | Illegal_renaming(name, modname, filename) -> fprintf ppf - "Wrong file naming: %a@ contains the compiled interface for @ %s when %s was expected" + "Wrong file naming: %a@ contains the compiled interface for @ \ + %s when %s was expected" Location.print_filename filename name modname | Inconsistent_import(name, source1, source2) -> fprintf ppf "@[<hov>The files %a@ and %a@ \ @@ -1810,4 +1811,3 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) - diff --git a/typing/ident.ml b/typing/ident.ml index 70438c83d0..db4ea69912 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -209,3 +209,15 @@ let rec iter f = function Empty -> () | Node(l, k, r, _) -> iter f l; f k.ident k.data; iter f r + +(* Idents for sharing keys *) + +(* They should be 'totally fresh' -> neg numbers *) +let key_name = "" + +let make_key_generator () = + let c = ref 1 in + fun id -> + let stamp = !c in + decr c ; + { id with name = key_name; stamp = stamp; } diff --git a/typing/ident.mli b/typing/ident.mli index d1cfa4ccb4..be226c2ddc 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -58,3 +58,8 @@ val find_all: string -> 'a tbl -> 'a list val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b val iter: (t -> 'a -> unit) -> 'a tbl -> unit + + +(* Idents for sharing keys *) + +val make_key_generator : unit -> (t -> t) diff --git a/typing/includecore.ml b/typing/includecore.ml index 13c4136ddc..523cf30c1a 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -230,7 +230,8 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = let mark cstrs usage name decl = List.iter (fun c -> - Env.mark_constructor_used usage name decl (Ident.name c.Types.cd_id)) + Env.mark_constructor_used usage name decl + (Ident.name c.Types.cd_id)) cstrs in let usage = diff --git a/typing/includemod.ml b/typing/includemod.ml index 1beb8488f5..4c8327862b 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -189,7 +189,7 @@ let rec modtypes env cxt subst mty1 mty2 = and try_modtypes env cxt subst mty1 mty2 = match (mty1, mty2) with - (Mty_alias p1, Mty_alias p2) -> + | (Mty_alias p1, Mty_alias p2) -> if Path.same p1 p2 then Tcoerce_none else let p1 = Env.normalize_path None env p1 and p2 = Env.normalize_path None env (Subst.module_path subst p2) in @@ -587,4 +587,3 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) - diff --git a/typing/mtype.ml b/typing/mtype.ml index 6f2c67aab2..17904500d9 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -71,7 +71,7 @@ and strengthen_sig env sg p = let newdecl = match decl.mtd_type with None -> - {decl with mtd_type = Some(Mty_ident(Pdot(p, Ident.name id, nopos)))} + {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id,nopos)))} | Some _ -> decl in diff --git a/typing/typecore.ml b/typing/typecore.ml index 9351572e22..9263bbfe74 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1911,8 +1911,9 @@ and type_expect ?in_function env sexp ty_expected = let previous_saved_types = Cmt_format.get_saved_types () in let prev_warnings = Typetexp.warning_attribute sexp.pexp_attributes in let exp = type_expect_ ?in_function env sexp ty_expected in - begin match prev_warnings with Some x -> Warnings.restore x | None -> () end; - Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types); + may Warnings.restore prev_warnings; + Cmt_format.set_saved_types + (Cmt_format.Partial_expression exp :: previous_saved_types); exp and type_expect_ ?in_function env sexp ty_expected = @@ -1966,16 +1967,21 @@ and type_expect_ ?in_function env sexp ty_expected = exp_env = env } end | Pexp_constant(Const_string (s, _) as cst) -> + let ty_exp = expand_head env ty_expected in + let ty = + (* Terrible hack for format strings *) + match ty_exp.desc with + Tconstr(path, _, _) when Path.same path Predef.path_format6 -> + if !Clflags.principal && ty_exp.level <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this coercion to format6"); + type_format loc s + | _ -> instance_def Predef.type_string + in rue { exp_desc = Texp_constant cst; exp_loc = loc; exp_extra = []; - exp_type = - (* Terrible hack for format strings *) - begin match (repr (expand_head env ty_expected)).desc with - Tconstr(path, _, _) when Path.same path Predef.path_format6 -> - type_format loc s - | _ -> instance_def Predef.type_string - end; + exp_type = ty; exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_constant cst -> @@ -2953,8 +2959,10 @@ and type_argument env sarg ty_expected' ty_expected = in let rec is_inferred sexp = match sexp.pexp_desc with - Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true - | Pexp_open (_, _, e) -> is_inferred e + Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _ + | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true + | Pexp_sequence (_, e) | Pexp_open (_, _, e) -> is_inferred e + | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2 | _ -> false in match expand_head env ty_expected' with diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 29fce4309e..da27a46875 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -1166,9 +1166,9 @@ let transl_value_decl env loc valdecl = val_attributes = valdecl.pval_attributes } | decl -> let arity = Ctype.arity ty in - if arity = 0 then - raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); let prim = Primitive.parse_declaration arity decl in + if arity = 0 && prim.prim_name.[0] <> '%' then + raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); if !Clflags.native_code && prim.prim_arity > 5 && prim.prim_native_name = "" diff --git a/typing/typedtree.mli b/typing/typedtree.mli index eabe828f8b..1e6c03e8c0 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -210,7 +210,8 @@ and structure_item_desc = | Tstr_primitive of value_description | Tstr_type of type_declaration list | Tstr_exception of constructor_declaration - | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc * attributes + | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc + * attributes | Tstr_module of module_binding | Tstr_recmodule of module_binding list | Tstr_modtype of module_type_declaration diff --git a/typing/typemod.ml b/typing/typemod.ml index 3d162fb2a7..aff624b7cf 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -198,7 +198,8 @@ let merge_constraint initial_env loc sg constr = when Ident.name id = s -> let path = Typetexp.find_module initial_env loc lid.txt in let md' = Env.find_module path env in - let newmd = Mtype.strengthen_decl env md' path in + let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in + let newmd = Mtype.strengthen_decl env md'' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); (Pident id, lid, Twith_module (path, lid)), Sig_module(id, newmd, rs) :: rem diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 7af01dc3eb..aed9d23f76 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -335,7 +335,7 @@ let rec transl_type env policy styp = let (path, decl) = find_type env styp.ptyp_loc lid.txt in if List.length stl <> decl.type_arity then raise(Error(styp.ptyp_loc, env, - Type_arity_mismatch(lid.txt, decl.type_arity, + Type_arity_mismatch(lid.txt, decl.type_arity, List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in @@ -843,8 +843,8 @@ let report_error env ppf = function fprintf ppf "The present constructor %s has no type" l | Constructor_mismatch (ty, ty') -> wrap_printing_env env (fun () -> - Printtyp.reset_and_mark_loops_list [ty; ty']; - fprintf ppf "@[<hov>%s %a@ %s@ %a@]" + Printtyp.reset_and_mark_loops_list [ty; ty']; + fprintf ppf "@[<hov>%s %a@ %s@ %a@]" "This variant type contains a constructor" Printtyp.type_expr ty "which should be" @@ -880,7 +880,7 @@ let report_error env ppf = function | Unbound_constructor lid -> fprintf ppf "Unbound constructor %a" longident lid; spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name) - env lid; + env lid; | Unbound_label lid -> fprintf ppf "Unbound record field %a" longident lid; spellcheck_simple ppf Env.fold_labels (fun d -> d.lbl_name) env lid; @@ -908,4 +908,3 @@ let () = | _ -> None ) - diff --git a/utils/config.mlbuild b/utils/config.mlbuild index 524558b163..c887ac2b4e 100644 --- a/utils/config.mlbuild +++ b/utils/config.mlbuild @@ -60,10 +60,10 @@ let mkdll = C.mkdll let mkexe = C.mkexe let mkmaindll = C.mkmaindll -let exec_magic_number = "Caml1999X010" +let exec_magic_number = "Caml1999X011" and cmi_magic_number = "Caml1999I016" -and cmo_magic_number = "Caml1999O008" -and cma_magic_number = "Caml1999A009" +and cmo_magic_number = "Caml1999O009" +and cma_magic_number = "Caml1999A010" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" and ast_impl_magic_number = "Caml1999M016" diff --git a/utils/config.mlp b/utils/config.mlp index 867b19fc66..209f90ce15 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -48,10 +48,10 @@ let mkdll = "%%MKDLL%%" let mkexe = "%%MKEXE%%" let mkmaindll = "%%MKMAINDLL%%" -let exec_magic_number = "Caml1999X010" +let exec_magic_number = "Caml1999X011" and cmi_magic_number = "Caml1999I017" -and cmo_magic_number = "Caml1999O008" -and cma_magic_number = "Caml1999A009" +and cmo_magic_number = "Caml1999O009" +and cma_magic_number = "Caml1999A010" and cmx_magic_number = "Caml1999Y012" and cmxa_magic_number = "Caml1999Z011" and ast_impl_magic_number = "Caml1999M016" |