clean up spaces and tabs
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@9547 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Damien Doligez
parent
bdc0fadee2
commit
04b1656222
6
Changes
6
Changes
|
|
@ -190,7 +190,7 @@ Compilers:
|
||||||
are tail calls.
|
are tail calls.
|
||||||
- All compiler error messages now include a file name and location, for
|
- All compiler error messages now include a file name and location, for
|
||||||
better interaction with Emacs' compilation mode.
|
better interaction with Emacs' compilation mode.
|
||||||
- Optimized compilation of "lazy e" when the argument "e" is
|
- Optimized compilation of "lazy e" when the argument "e" is
|
||||||
already evaluated.
|
already evaluated.
|
||||||
- Optimized compilation of equality tests with a variant constant constructor.
|
- Optimized compilation of equality tests with a variant constant constructor.
|
||||||
- The -dllib options recorded in libraries are no longer ignored when
|
- The -dllib options recorded in libraries are no longer ignored when
|
||||||
|
|
@ -243,7 +243,7 @@ Other libraries:
|
||||||
- Dynlink: on some platforms, the Dynlink library is now available in
|
- Dynlink: on some platforms, the Dynlink library is now available in
|
||||||
native code. The boolean Dynlink.is_native allows the program to
|
native code. The boolean Dynlink.is_native allows the program to
|
||||||
know whether it has been compiled in bytecode or in native code.
|
know whether it has been compiled in bytecode or in native code.
|
||||||
- Bigarrays: added "unsafe_get" and "unsafe_set"
|
- Bigarrays: added "unsafe_get" and "unsafe_set"
|
||||||
(non-bound-checking versions of "get" and "set").
|
(non-bound-checking versions of "get" and "set").
|
||||||
- Bigarrays: removed limitation "array dimension < 2^31".
|
- Bigarrays: removed limitation "array dimension < 2^31".
|
||||||
- Labltk: added support for TK 8.5.
|
- Labltk: added support for TK 8.5.
|
||||||
|
|
@ -274,7 +274,7 @@ Bug fixes:
|
||||||
out-of-heap pointers.
|
out-of-heap pointers.
|
||||||
- PR#3915: updated most man pages.
|
- PR#3915: updated most man pages.
|
||||||
- PR#4261: type-checking of recursive modules
|
- PR#4261: type-checking of recursive modules
|
||||||
- PR#4308: better stack backtraces for "spontaneous" exceptions such as
|
- PR#4308: better stack backtraces for "spontaneous" exceptions such as
|
||||||
Stack_overflow, Out_of_memory, etc.
|
Stack_overflow, Out_of_memory, etc.
|
||||||
- PR#4338: Str.global_substitute, Str.global_replace and the Str.*split*
|
- PR#4338: Str.global_substitute, Str.global_replace and the Str.*split*
|
||||||
functions are now tail-recursive.
|
functions are now tail-recursive.
|
||||||
|
|
|
||||||
2
INSTALL
2
INSTALL
|
|
@ -78,7 +78,7 @@ The "configure" script accepts the following options:
|
||||||
LablTk. "-tkdefs" helps to find the headers, and "-tklibs"
|
LablTk. "-tkdefs" helps to find the headers, and "-tklibs"
|
||||||
the C libraries. "-tklibs" may contain either only -L/path and
|
the C libraries. "-tklibs" may contain either only -L/path and
|
||||||
-Wl,... flags, in which case the library names are determined
|
-Wl,... flags, in which case the library names are determined
|
||||||
automatically, or the actual libraries, which are used as given.
|
automatically, or the actual libraries, which are used as given.
|
||||||
Example: for a Japanese tcl/tk whose headers are in specific
|
Example: for a Japanese tcl/tk whose headers are in specific
|
||||||
directories and libraries in /usr/local/lib, you can use
|
directories and libraries in /usr/local/lib, you can use
|
||||||
./configure -tklibs "-L/usr/local/lib -ltk8.0jp -ltcl8.0jp"
|
./configure -tklibs "-L/usr/local/lib -ltk8.0jp -ltcl8.0jp"
|
||||||
|
|
|
||||||
96
Makefile
96
Makefile
|
|
@ -32,7 +32,7 @@ SHELL=/bin/sh
|
||||||
MKDIR=mkdir -p
|
MKDIR=mkdir -p
|
||||||
|
|
||||||
INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
|
INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
|
||||||
-I toplevel
|
-I toplevel
|
||||||
|
|
||||||
UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
|
UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
|
||||||
utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
|
utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
|
||||||
|
|
@ -192,9 +192,9 @@ coldstart:
|
||||||
cd stdlib; $(MAKE) COMPILER=../boot/ocamlc all
|
cd stdlib; $(MAKE) COMPILER=../boot/ocamlc all
|
||||||
cd stdlib; cp $(LIBFILES) ../boot
|
cd stdlib; cp $(LIBFILES) ../boot
|
||||||
if test -f boot/libcamlrun.a; then :; else \
|
if test -f boot/libcamlrun.a; then :; else \
|
||||||
ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi
|
ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi
|
||||||
if test -d stdlib/caml; then :; else \
|
if test -d stdlib/caml; then :; else \
|
||||||
ln -s ../byterun stdlib/caml; fi
|
ln -s ../byterun stdlib/caml; fi
|
||||||
|
|
||||||
# Build the core system: the minimum needed to make depend and bootstrap
|
# Build the core system: the minimum needed to make depend and bootstrap
|
||||||
core: coldstart ocamlc ocamllex ocamlyacc ocamltools library
|
core: coldstart ocamlc ocamllex ocamlyacc ocamltools library
|
||||||
|
|
@ -240,7 +240,7 @@ compare:
|
||||||
@if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex \
|
@if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex \
|
||||||
&& cmp boot/ocamldep tools/ocamldep; \
|
&& cmp boot/ocamldep tools/ocamldep; \
|
||||||
then echo "Fixpoint reached, bootstrap succeeded."; \
|
then echo "Fixpoint reached, bootstrap succeeded."; \
|
||||||
else echo "Fixpoint not reached, try one more bootstrapping cycle."; \
|
else echo "Fixpoint not reached, try one more bootstrapping cycle."; \
|
||||||
fi
|
fi
|
||||||
|
|
||||||
# Remove old bootstrap compilers
|
# Remove old bootstrap compilers
|
||||||
|
|
@ -262,9 +262,9 @@ opt:
|
||||||
|
|
||||||
# Native-code versions of the tools
|
# Native-code versions of the tools
|
||||||
opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \
|
opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \
|
||||||
ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \
|
ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \
|
||||||
otherlibrariesopt \
|
otherlibrariesopt \
|
||||||
ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt
|
ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt
|
||||||
|
|
||||||
# Installation
|
# Installation
|
||||||
install:
|
install:
|
||||||
|
|
@ -274,8 +274,8 @@ install:
|
||||||
if test -d $(MANDIR)/man$(MANEXT); then : ; \
|
if test -d $(MANDIR)/man$(MANEXT); then : ; \
|
||||||
else $(MKDIR) $(MANDIR)/man$(MANEXT); fi
|
else $(MKDIR) $(MANDIR)/man$(MANEXT); fi
|
||||||
cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \
|
cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \
|
||||||
dllthreads.so dllunix.so dllgraphics.so dllmldbm.so dllstr.so \
|
dllthreads.so dllunix.so dllgraphics.so dllmldbm.so dllstr.so \
|
||||||
dlltkanim.so
|
dlltkanim.so
|
||||||
cd byterun; $(MAKE) install
|
cd byterun; $(MAKE) install
|
||||||
cp ocamlc $(BINDIR)/ocamlc$(EXE)
|
cp ocamlc $(BINDIR)/ocamlc$(EXE)
|
||||||
cp ocaml $(BINDIR)/ocaml$(EXE)
|
cp ocaml $(BINDIR)/ocaml$(EXE)
|
||||||
|
|
@ -291,8 +291,8 @@ install:
|
||||||
cd tools; $(MAKE) install
|
cd tools; $(MAKE) install
|
||||||
-cd man; $(MAKE) install
|
-cd man; $(MAKE) install
|
||||||
for i in $(OTHERLIBRARIES); do \
|
for i in $(OTHERLIBRARIES); do \
|
||||||
(cd otherlibs/$$i; $(MAKE) install) || exit $$?; \
|
(cd otherlibs/$$i; $(MAKE) install) || exit $$?; \
|
||||||
done
|
done
|
||||||
cd ocamldoc; $(MAKE) install
|
cd ocamldoc; $(MAKE) install
|
||||||
if test -f ocamlopt; then $(MAKE) installopt; else :; fi
|
if test -f ocamlopt; then $(MAKE) installopt; else :; fi
|
||||||
if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \
|
if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \
|
||||||
|
|
@ -355,7 +355,7 @@ partialclean::
|
||||||
|
|
||||||
# The native toplevel
|
# The native toplevel
|
||||||
|
|
||||||
ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx)
|
ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx)
|
||||||
$(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \
|
$(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \
|
||||||
$(NATTOPOBJS:.cmo=.cmx) -linkall
|
$(NATTOPOBJS:.cmo=.cmx) -linkall
|
||||||
|
|
||||||
|
|
@ -369,28 +369,28 @@ otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml
|
||||||
utils/config.ml: utils/config.mlp config/Makefile
|
utils/config.ml: utils/config.mlp config/Makefile
|
||||||
@rm -f utils/config.ml
|
@rm -f utils/config.ml
|
||||||
sed -e 's|%%LIBDIR%%|$(LIBDIR)|' \
|
sed -e 's|%%LIBDIR%%|$(LIBDIR)|' \
|
||||||
-e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \
|
-e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \
|
||||||
-e 's|%%CCOMPTYPE%%|cc|' \
|
-e 's|%%CCOMPTYPE%%|cc|' \
|
||||||
-e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \
|
-e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \
|
||||||
-e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \
|
-e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \
|
||||||
-e 's|%%PACKLD%%|$(PACKLD)|' \
|
-e 's|%%PACKLD%%|$(PACKLD)|' \
|
||||||
-e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \
|
-e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \
|
||||||
-e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \
|
-e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \
|
||||||
-e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
|
-e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
|
||||||
-e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \
|
-e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \
|
||||||
-e 's|%%ARCH%%|$(ARCH)|' \
|
-e 's|%%ARCH%%|$(ARCH)|' \
|
||||||
-e 's|%%MODEL%%|$(MODEL)|' \
|
-e 's|%%MODEL%%|$(MODEL)|' \
|
||||||
-e 's|%%SYSTEM%%|$(SYSTEM)|' \
|
-e 's|%%SYSTEM%%|$(SYSTEM)|' \
|
||||||
-e 's|%%EXT_OBJ%%|.o|' \
|
-e 's|%%EXT_OBJ%%|.o|' \
|
||||||
-e 's|%%EXT_ASM%%|.s|' \
|
-e 's|%%EXT_ASM%%|.s|' \
|
||||||
-e 's|%%EXT_LIB%%|.a|' \
|
-e 's|%%EXT_LIB%%|.a|' \
|
||||||
-e 's|%%EXT_DLL%%|.so|' \
|
-e 's|%%EXT_DLL%%|.so|' \
|
||||||
-e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
|
-e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
|
||||||
-e 's|%%ASM%%|$(ASM)|' \
|
-e 's|%%ASM%%|$(ASM)|' \
|
||||||
-e 's|%%MKDLL%%|$(MKDLL)|' \
|
-e 's|%%MKDLL%%|$(MKDLL)|' \
|
||||||
-e 's|%%MKEXE%%|$(MKEXE)|' \
|
-e 's|%%MKEXE%%|$(MKEXE)|' \
|
||||||
-e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
|
-e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
|
||||||
utils/config.mlp > utils/config.ml
|
utils/config.mlp > utils/config.ml
|
||||||
@chmod -w utils/config.ml
|
@chmod -w utils/config.ml
|
||||||
|
|
||||||
partialclean::
|
partialclean::
|
||||||
|
|
@ -433,8 +433,8 @@ beforedepend:: parsing/linenum.ml
|
||||||
ocamlc.opt: $(COMPOBJS:.cmo=.cmx)
|
ocamlc.opt: $(COMPOBJS:.cmo=.cmx)
|
||||||
cd asmrun; $(MAKE) meta.o dynlink.o
|
cd asmrun; $(MAKE) meta.o dynlink.o
|
||||||
$(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \
|
$(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \
|
||||||
$(COMPOBJS:.cmo=.cmx) \
|
$(COMPOBJS:.cmo=.cmx) \
|
||||||
asmrun/meta.o asmrun/dynlink.o -cclib "$(BYTECCLIBS)"
|
asmrun/meta.o asmrun/dynlink.o -cclib "$(BYTECCLIBS)"
|
||||||
@sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \
|
@sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \
|
||||||
driver/ocamlcomp.sh.in > ocamlcomp.sh
|
driver/ocamlcomp.sh.in > ocamlcomp.sh
|
||||||
@chmod +x ocamlcomp.sh
|
@chmod +x ocamlcomp.sh
|
||||||
|
|
@ -459,7 +459,7 @@ $(OPTOBJS:.cmo=.cmx): ocamlopt
|
||||||
|
|
||||||
bytecomp/opcodes.ml: byterun/instruct.h
|
bytecomp/opcodes.ml: byterun/instruct.h
|
||||||
sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \
|
sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \
|
||||||
awk -f tools/make-opcodes > bytecomp/opcodes.ml
|
awk -f tools/make-opcodes > bytecomp/opcodes.ml
|
||||||
|
|
||||||
partialclean::
|
partialclean::
|
||||||
rm -f bytecomp/opcodes.ml
|
rm -f bytecomp/opcodes.ml
|
||||||
|
|
@ -475,9 +475,9 @@ bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h
|
||||||
(echo 'let builtin_exceptions = [|'; \
|
(echo 'let builtin_exceptions = [|'; \
|
||||||
sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \
|
sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \
|
||||||
sed -e '$$s/;$$//'; \
|
sed -e '$$s/;$$//'; \
|
||||||
echo '|]'; \
|
echo '|]'; \
|
||||||
echo 'let builtin_primitives = [|'; \
|
echo 'let builtin_primitives = [|'; \
|
||||||
sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \
|
sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \
|
||||||
echo '|]') > bytecomp/runtimedef.ml
|
echo '|]') > bytecomp/runtimedef.ml
|
||||||
|
|
||||||
partialclean::
|
partialclean::
|
||||||
|
|
@ -531,7 +531,7 @@ beforedepend:: asmcomp/scheduling.ml
|
||||||
|
|
||||||
asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit
|
asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit
|
||||||
$(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \
|
$(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \
|
||||||
|| { rm -f asmcomp/emit.ml; exit 2; }
|
|| { rm -f asmcomp/emit.ml; exit 2; }
|
||||||
|
|
||||||
partialclean::
|
partialclean::
|
||||||
rm -f asmcomp/emit.ml
|
rm -f asmcomp/emit.ml
|
||||||
|
|
@ -555,7 +555,7 @@ partialclean::
|
||||||
runtime:
|
runtime:
|
||||||
cd byterun; $(MAKE) all
|
cd byterun; $(MAKE) all
|
||||||
if test -f stdlib/libcamlrun.a; then :; else \
|
if test -f stdlib/libcamlrun.a; then :; else \
|
||||||
ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi
|
ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi
|
||||||
|
|
||||||
clean::
|
clean::
|
||||||
cd byterun; $(MAKE) clean
|
cd byterun; $(MAKE) clean
|
||||||
|
|
@ -649,18 +649,18 @@ alldepend::
|
||||||
|
|
||||||
otherlibraries: ocamltools
|
otherlibraries: ocamltools
|
||||||
for i in $(OTHERLIBRARIES); do \
|
for i in $(OTHERLIBRARIES); do \
|
||||||
(cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \
|
(cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \
|
||||||
done
|
done
|
||||||
|
|
||||||
otherlibrariesopt:
|
otherlibrariesopt:
|
||||||
for i in $(OTHERLIBRARIES); do \
|
for i in $(OTHERLIBRARIES); do \
|
||||||
(cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \
|
(cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \
|
||||||
done
|
done
|
||||||
|
|
||||||
partialclean::
|
partialclean::
|
||||||
for i in $(OTHERLIBRARIES); do \
|
for i in $(OTHERLIBRARIES); do \
|
||||||
(cd otherlibs/$$i; $(MAKE) partialclean); \
|
(cd otherlibs/$$i; $(MAKE) partialclean); \
|
||||||
done
|
done
|
||||||
|
|
||||||
clean::
|
clean::
|
||||||
for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) clean); done
|
for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) clean); done
|
||||||
|
|
|
||||||
66
Makefile.nt
66
Makefile.nt
|
|
@ -29,7 +29,7 @@ DEPFLAGS=$(INCLUDES)
|
||||||
CAMLRUN=byterun/ocamlrun
|
CAMLRUN=byterun/ocamlrun
|
||||||
|
|
||||||
INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
|
INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
|
||||||
-I toplevel
|
-I toplevel
|
||||||
|
|
||||||
UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
|
UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
|
||||||
utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
|
utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
|
||||||
|
|
@ -295,7 +295,7 @@ partialclean::
|
||||||
|
|
||||||
# The native toplevel
|
# The native toplevel
|
||||||
|
|
||||||
ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx)
|
ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx)
|
||||||
$(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat $(NATTOPOBJS:.cmo=.cmx) -linkall
|
$(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat $(NATTOPOBJS:.cmo=.cmx) -linkall
|
||||||
|
|
||||||
toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa
|
toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa
|
||||||
|
|
@ -309,31 +309,31 @@ otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml
|
||||||
utils/config.ml: utils/config.mlp config/Makefile
|
utils/config.ml: utils/config.mlp config/Makefile
|
||||||
@rm -f utils/config.ml
|
@rm -f utils/config.ml
|
||||||
sed -e "s|%%LIBDIR%%|$(LIBDIR)|" \
|
sed -e "s|%%LIBDIR%%|$(LIBDIR)|" \
|
||||||
-e "s|%%BYTERUN%%|ocamlrun|" \
|
-e "s|%%BYTERUN%%|ocamlrun|" \
|
||||||
-e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \
|
-e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \
|
||||||
-e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \
|
-e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \
|
||||||
-e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \
|
-e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \
|
||||||
-e "s|%%PARTIALLD%%|$(PARTIALLD)|" \
|
-e "s|%%PARTIALLD%%|$(PARTIALLD)|" \
|
||||||
-e "s|%%PACKLD%%|$(PACKLD)|" \
|
-e "s|%%PACKLD%%|$(PACKLD)|" \
|
||||||
-e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \
|
-e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \
|
||||||
-e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \
|
-e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \
|
||||||
-e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
|
-e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
|
||||||
-e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \
|
-e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \
|
||||||
-e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \
|
-e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \
|
||||||
-e "s|%%ARCH%%|$(ARCH)|" \
|
-e "s|%%ARCH%%|$(ARCH)|" \
|
||||||
-e "s|%%MODEL%%|$(MODEL)|" \
|
-e "s|%%MODEL%%|$(MODEL)|" \
|
||||||
-e "s|%%SYSTEM%%|$(SYSTEM)|" \
|
-e "s|%%SYSTEM%%|$(SYSTEM)|" \
|
||||||
-e "s|%%EXT_OBJ%%|.$(O)|" \
|
-e "s|%%EXT_OBJ%%|.$(O)|" \
|
||||||
-e "s|%%EXT_ASM%%|.$(S)|" \
|
-e "s|%%EXT_ASM%%|.$(S)|" \
|
||||||
-e "s|%%EXT_LIB%%|.$(A)|" \
|
-e "s|%%EXT_LIB%%|.$(A)|" \
|
||||||
-e "s|%%EXT_DLL%%|.dll|" \
|
-e "s|%%EXT_DLL%%|.dll|" \
|
||||||
-e "s|%%SYSTHREAD_SUPPORT%%|true|" \
|
-e "s|%%SYSTHREAD_SUPPORT%%|true|" \
|
||||||
-e 's|%%ASM%%|$(ASM)|' \
|
-e 's|%%ASM%%|$(ASM)|' \
|
||||||
-e 's|%%MKDLL%%|$(MKDLL)|' \
|
-e 's|%%MKDLL%%|$(MKDLL)|' \
|
||||||
-e 's|%%MKEXE%%|$(MKEXE)|' \
|
-e 's|%%MKEXE%%|$(MKEXE)|' \
|
||||||
-e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
|
-e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
|
||||||
-e 's|%%CC_PROFILE%%||' \
|
-e 's|%%CC_PROFILE%%||' \
|
||||||
utils/config.mlp > utils/config.ml
|
utils/config.mlp > utils/config.ml
|
||||||
@chmod -w utils/config.ml
|
@chmod -w utils/config.ml
|
||||||
|
|
||||||
partialclean::
|
partialclean::
|
||||||
|
|
@ -394,7 +394,7 @@ $(OPTOBJS:.cmo=.cmx): ocamlopt
|
||||||
|
|
||||||
bytecomp/opcodes.ml: byterun/instruct.h
|
bytecomp/opcodes.ml: byterun/instruct.h
|
||||||
sed -n -e "/^enum/p" -e "s|,||g" -e "/^ /p" byterun/instruct.h | \
|
sed -n -e "/^enum/p" -e "s|,||g" -e "/^ /p" byterun/instruct.h | \
|
||||||
gawk -f tools/make-opcodes > bytecomp/opcodes.ml
|
gawk -f tools/make-opcodes > bytecomp/opcodes.ml
|
||||||
|
|
||||||
partialclean::
|
partialclean::
|
||||||
rm -f bytecomp/opcodes.ml
|
rm -f bytecomp/opcodes.ml
|
||||||
|
|
@ -410,9 +410,9 @@ bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h
|
||||||
(echo 'let builtin_exceptions = [|'; \
|
(echo 'let builtin_exceptions = [|'; \
|
||||||
sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \
|
sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \
|
||||||
sed -e '$$s/;$$//'; \
|
sed -e '$$s/;$$//'; \
|
||||||
echo '|]'; \
|
echo '|]'; \
|
||||||
echo 'let builtin_primitives = [|'; \
|
echo 'let builtin_primitives = [|'; \
|
||||||
sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \
|
sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \
|
||||||
echo '|]') > bytecomp/runtimedef.ml
|
echo '|]') > bytecomp/runtimedef.ml
|
||||||
|
|
||||||
partialclean::
|
partialclean::
|
||||||
|
|
@ -561,9 +561,9 @@ alldepend::
|
||||||
|
|
||||||
# OCamldoc
|
# OCamldoc
|
||||||
|
|
||||||
ocamldoc.byte:
|
ocamldoc.byte:
|
||||||
cd ocamldoc ; $(MAKEREC) all
|
cd ocamldoc ; $(MAKEREC) all
|
||||||
ocamldoc.opt:
|
ocamldoc.opt:
|
||||||
cd ocamldoc ; $(MAKEREC) opt.opt
|
cd ocamldoc ; $(MAKEREC) opt.opt
|
||||||
partialclean::
|
partialclean::
|
||||||
cd ocamldoc ; $(MAKEREC) clean
|
cd ocamldoc ; $(MAKEREC) clean
|
||||||
|
|
|
||||||
2
README
2
README
|
|
@ -84,7 +84,7 @@ All files marked "Copyright INRIA" in this distribution are copyright
|
||||||
|
|
||||||
INSTALLATION:
|
INSTALLATION:
|
||||||
|
|
||||||
See the file INSTALL for installation instructions on Unix, Linux and
|
See the file INSTALL for installation instructions on Unix, Linux and
|
||||||
MacOS X machines. For MS Windows, see README.win32.
|
MacOS X machines. For MS Windows, see README.win32.
|
||||||
|
|
||||||
DOCUMENTATION:
|
DOCUMENTATION:
|
||||||
|
|
|
||||||
20
README.win32
20
README.win32
|
|
@ -6,7 +6,7 @@ There are no less than four ports of Objective Caml for MS Windows available:
|
||||||
- a native Win32 port, built with the Cygwin/MinGW development tools;
|
- a native Win32 port, built with the Cygwin/MinGW development tools;
|
||||||
- a port consisting of the Unix sources compiled under the Cygwin
|
- a port consisting of the Unix sources compiled under the Cygwin
|
||||||
Unix-like environment for Windows;
|
Unix-like environment for Windows;
|
||||||
- a native Win64 port (64-bit Windows), built with the Microsoft
|
- a native Win64 port (64-bit Windows), built with the Microsoft
|
||||||
development tools.
|
development tools.
|
||||||
|
|
||||||
Here is a summary of the main differences between these ports:
|
Here is a summary of the main differences between these ports:
|
||||||
|
|
@ -95,7 +95,7 @@ THIRD-PARTY SOFTWARE:
|
||||||
2005 can download MASM version 8 from
|
2005 can download MASM version 8 from
|
||||||
http://www.microsoft.com/downloads/details.aspx?FamilyID=7A1C9DA0-0510-44A2-B042-7EF370530C64&displaylang=en
|
http://www.microsoft.com/downloads/details.aspx?FamilyID=7A1C9DA0-0510-44A2-B042-7EF370530C64&displaylang=en
|
||||||
To obtain MASM version 6.11, see
|
To obtain MASM version 6.11, see
|
||||||
http://users.easystreet.com/jkirwan/new/pctools.html.
|
http://users.easystreet.com/jkirwan/new/pctools.html.
|
||||||
|
|
||||||
[4] TCL/TK version 8.5. Windows binaries are available as part of the
|
[4] TCL/TK version 8.5. Windows binaries are available as part of the
|
||||||
ActiveTCL distribution at http://www.activestate.com/products/ActiveTcl/
|
ActiveTCL distribution at http://www.activestate.com/products/ActiveTcl/
|
||||||
|
|
@ -152,7 +152,7 @@ performance of bytecode programs is about 2/3 of that obtained under
|
||||||
Unix/GCC or Cygwin or Mingw on similar hardware.
|
Unix/GCC or Cygwin or Mingw on similar hardware.
|
||||||
|
|
||||||
* Libraries available in this port: "num", "str", "threads", "graphics",
|
* Libraries available in this port: "num", "str", "threads", "graphics",
|
||||||
"labltk", and large parts of "unix".
|
"labltk", and large parts of "unix".
|
||||||
|
|
||||||
* The replay debugger is partially supported (no reverse execution).
|
* The replay debugger is partially supported (no reverse execution).
|
||||||
|
|
||||||
|
|
@ -178,7 +178,7 @@ The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...)
|
||||||
runs without any additional tools.
|
runs without any additional tools.
|
||||||
|
|
||||||
The native-code compiler (ocamlopt), as well as static linking of
|
The native-code compiler (ocamlopt), as well as static linking of
|
||||||
Caml bytecode with C code (ocamlc -custom), require
|
Caml bytecode with C code (ocamlc -custom), require
|
||||||
the Cygwin development tools, available at
|
the Cygwin development tools, available at
|
||||||
http://www.cygwin.com/
|
http://www.cygwin.com/
|
||||||
and the flexdll tool, available at
|
and the flexdll tool, available at
|
||||||
|
|
@ -191,7 +191,7 @@ Do *not* install the Mingw/MSYS development tools from www.mingw.org:
|
||||||
these are not compatible with this Caml port (@responsefile not
|
these are not compatible with this Caml port (@responsefile not
|
||||||
recognized on the command line).
|
recognized on the command line).
|
||||||
|
|
||||||
The LablTk GUI requires Tcl/Tk 8.5. Windows binaries are available
|
The LablTk GUI requires Tcl/Tk 8.5. Windows binaries are available
|
||||||
as part of the ActiveTCL distribution at
|
as part of the ActiveTCL distribution at
|
||||||
http://www.activestate.com/products/ActiveTcl/
|
http://www.activestate.com/products/ActiveTcl/
|
||||||
|
|
||||||
|
|
@ -216,7 +216,7 @@ RECOMPILATION FROM THE SOURCES:
|
||||||
You will need the following software components to perform the recompilation:
|
You will need the following software components to perform the recompilation:
|
||||||
- Windows NT, 2000, XP, or Vista.
|
- Windows NT, 2000, XP, or Vista.
|
||||||
- Cygwin: http://sourceware.cygnus.com/cygwin/
|
- Cygwin: http://sourceware.cygnus.com/cygwin/
|
||||||
Install at least the following packages: binutils, diffutils,
|
Install at least the following packages: binutils, diffutils,
|
||||||
gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32-api.
|
gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32-api.
|
||||||
- TCL/TK version 8.5 (see above).
|
- TCL/TK version 8.5 (see above).
|
||||||
- The flexdll tool (see above).
|
- The flexdll tool (see above).
|
||||||
|
|
@ -238,7 +238,7 @@ Normally, the only variables that need to be changed are
|
||||||
PREFIX where to install everything
|
PREFIX where to install everything
|
||||||
TK_ROOT where TCL/TK was installed
|
TK_ROOT where TCL/TK was installed
|
||||||
|
|
||||||
Finally, use "make -f Makefile.nt" to build the system, e.g.
|
Finally, use "make -f Makefile.nt" to build the system, e.g.
|
||||||
|
|
||||||
make -f Makefile.nt world
|
make -f Makefile.nt world
|
||||||
make -f Makefile.nt bootstrap
|
make -f Makefile.nt bootstrap
|
||||||
|
|
@ -250,7 +250,7 @@ Finally, use "make -f Makefile.nt" to build the system, e.g.
|
||||||
NOTES:
|
NOTES:
|
||||||
|
|
||||||
* Libraries available in this port: "num", "str", "threads", "graphics",
|
* Libraries available in this port: "num", "str", "threads", "graphics",
|
||||||
"labltk", and large parts of "unix".
|
"labltk", and large parts of "unix".
|
||||||
|
|
||||||
* The replay debugger is partially supported (no reverse execution).
|
* The replay debugger is partially supported (no reverse execution).
|
||||||
|
|
||||||
|
|
@ -357,7 +357,7 @@ compiler for AMD64 instead of the Platform SDK compiler, replace the line
|
||||||
by
|
by
|
||||||
EXTRALIBS=
|
EXTRALIBS=
|
||||||
|
|
||||||
Finally, use "make -f Makefile.nt" to build the system, e.g.
|
Finally, use "make -f Makefile.nt" to build the system, e.g.
|
||||||
|
|
||||||
make -f Makefile.nt world
|
make -f Makefile.nt world
|
||||||
make -f Makefile.nt bootstrap
|
make -f Makefile.nt bootstrap
|
||||||
|
|
@ -369,7 +369,7 @@ Finally, use "make -f Makefile.nt" to build the system, e.g.
|
||||||
NOTES:
|
NOTES:
|
||||||
|
|
||||||
* Libraries available in this port: "num", "str", "threads", "graphics",
|
* Libraries available in this port: "num", "str", "threads", "graphics",
|
||||||
and large parts of "unix".
|
and large parts of "unix".
|
||||||
|
|
||||||
* The replay debugger is partially supported (no reverse execution).
|
* The replay debugger is partially supported (no reverse execution).
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -97,7 +97,7 @@ A8: The new default mode is more flexible than the original commuting
|
||||||
interface must also be present in the implementation.
|
interface must also be present in the implementation.
|
||||||
The addlabels tool can help you to do that. Suppose that you have
|
The addlabels tool can help you to do that. Suppose that you have
|
||||||
mymod.ml and mymod.mli, where mymod.mli adds some labels. Then
|
mymod.ml and mymod.mli, where mymod.mli adds some labels. Then
|
||||||
doing
|
doing
|
||||||
$CAMLLIB/addlabels mymod.ml
|
$CAMLLIB/addlabels mymod.ml
|
||||||
will insert labels from the interface inside the implementation.
|
will insert labels from the interface inside the implementation.
|
||||||
It also takes care of inserting them in recursive calls, as
|
It also takes care of inserting them in recursive calls, as
|
||||||
|
|
@ -106,4 +106,4 @@ A8: The new default mode is more flexible than the original commuting
|
||||||
If you used labels from standard libraries, you will also have
|
If you used labels from standard libraries, you will also have
|
||||||
problems with them. You can proceed as described in A6. Since you
|
problems with them. You can proceed as described in A6. Since you
|
||||||
used classic mode, you do not need to bother about changed
|
used classic mode, you do not need to bother about changed
|
||||||
argument order.
|
argument order.
|
||||||
|
|
|
||||||
|
|
@ -129,7 +129,7 @@ let emit_label lbl =
|
||||||
emit_string "$"; emit_int lbl
|
emit_string "$"; emit_int lbl
|
||||||
|
|
||||||
let emit_Llabel fallthrough lbl =
|
let emit_Llabel fallthrough lbl =
|
||||||
if (not fallthrough) then begin
|
if (not fallthrough) then begin
|
||||||
emit_string " .align 4\n"
|
emit_string " .align 4\n"
|
||||||
end ;
|
end ;
|
||||||
emit_label lbl
|
emit_label lbl
|
||||||
|
|
@ -195,7 +195,7 @@ let int_reg_number = [|
|
||||||
0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12;
|
0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12;
|
||||||
16; 17; 18; 19; 20; 21; 22
|
16; 17; 18; 19; 20; 21; 22
|
||||||
|]
|
|]
|
||||||
|
|
||||||
let float_reg_number = [|
|
let float_reg_number = [|
|
||||||
0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15;
|
0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15;
|
||||||
16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 29; 30
|
16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 29; 30
|
||||||
|
|
@ -358,7 +358,7 @@ let emit_instr fallthrough i =
|
||||||
Lend -> ()
|
Lend -> ()
|
||||||
| Lop(Imove | Ispill | Ireload) ->
|
| Lop(Imove | Ispill | Ireload) ->
|
||||||
let src = i.arg.(0) and dst = i.res.(0) in
|
let src = i.arg.(0) and dst = i.res.(0) in
|
||||||
if src.loc <> dst.loc then begin
|
if src.loc <> dst.loc then begin
|
||||||
match (src.loc, dst.loc) with
|
match (src.loc, dst.loc) with
|
||||||
(Reg rs, Reg rd) ->
|
(Reg rs, Reg rd) ->
|
||||||
if src.typ = Float then
|
if src.typ = Float then
|
||||||
|
|
@ -381,7 +381,7 @@ let emit_instr fallthrough i =
|
||||||
| Lop(Iconst_int n) ->
|
| Lop(Iconst_int n) ->
|
||||||
if n = 0n then
|
if n = 0n then
|
||||||
` clr {emit_reg i.res.(0)}\n`
|
` clr {emit_reg i.res.(0)}\n`
|
||||||
else if digital_asm ||
|
else if digital_asm ||
|
||||||
(n >= Nativeint.of_int (-0x80000000) &&
|
(n >= Nativeint.of_int (-0x80000000) &&
|
||||||
n <= Nativeint.of_int 0x7FFFFFFF) then
|
n <= Nativeint.of_int 0x7FFFFFFF) then
|
||||||
` ldiq {emit_reg i.res.(0)}, {emit_nativeint n}\n`
|
` ldiq {emit_reg i.res.(0)}, {emit_nativeint n}\n`
|
||||||
|
|
|
||||||
|
|
@ -49,7 +49,7 @@ let int_reg_name = [|
|
||||||
(* 8-12 *) "$8"; "$9"; "$10"; "$11"; "$12";
|
(* 8-12 *) "$8"; "$9"; "$10"; "$11"; "$12";
|
||||||
(* 13-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21"; "$22"
|
(* 13-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21"; "$22"
|
||||||
|]
|
|]
|
||||||
|
|
||||||
let float_reg_name = [|
|
let float_reg_name = [|
|
||||||
(* 100-107 *) "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7";
|
(* 100-107 *) "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7";
|
||||||
(* 108-115 *) "$f8"; "$f9"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15";
|
(* 108-115 *) "$f8"; "$f9"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15";
|
||||||
|
|
@ -210,7 +210,7 @@ let assemble_file infile outfile =
|
||||||
if digital_asm && !Clflags.gprofile
|
if digital_asm && !Clflags.gprofile
|
||||||
then Config.as ^ " -pg"
|
then Config.as ^ " -pg"
|
||||||
else Config.as in
|
else Config.as in
|
||||||
Ccomp.command (as_cmd ^ " -o " ^
|
Ccomp.command (as_cmd ^ " -o " ^
|
||||||
Filename.quote outfile ^ " " ^ Filename.quote infile)
|
Filename.quote outfile ^ " " ^ Filename.quote infile)
|
||||||
|
|
||||||
open Clflags;;
|
open Clflags;;
|
||||||
|
|
|
||||||
|
|
@ -60,7 +60,7 @@ let slot_offset loc cl =
|
||||||
(* Symbols *)
|
(* Symbols *)
|
||||||
|
|
||||||
let emit_symbol s =
|
let emit_symbol s =
|
||||||
if macosx then emit_string "_";
|
if macosx then emit_string "_";
|
||||||
Emitaux.emit_symbol '$' s
|
Emitaux.emit_symbol '$' s
|
||||||
|
|
||||||
let emit_call s =
|
let emit_call s =
|
||||||
|
|
@ -791,4 +791,3 @@ let end_assembly() =
|
||||||
if Config.system = "linux" then
|
if Config.system = "linux" then
|
||||||
(* Mark stack as non-executable, PR#4564 *)
|
(* Mark stack as non-executable, PR#4564 *)
|
||||||
` .section .note.GNU-stack,\"\",%progbits\n`
|
` .section .note.GNU-stack,\"\",%progbits\n`
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -39,10 +39,10 @@ let frame_required () =
|
||||||
|
|
||||||
let frame_size () = (* includes return address *)
|
let frame_size () = (* includes return address *)
|
||||||
if frame_required() then begin
|
if frame_required() then begin
|
||||||
let sz =
|
let sz =
|
||||||
(!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8)
|
(!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8)
|
||||||
in Misc.align sz 16
|
in Misc.align sz 16
|
||||||
end else
|
end else
|
||||||
!stack_offset + 8
|
!stack_offset + 8
|
||||||
|
|
||||||
let slot_offset loc cl =
|
let slot_offset loc cl =
|
||||||
|
|
@ -63,7 +63,7 @@ let emit_int32 n = emit_printf "0%lxh" n
|
||||||
let emit_symbol s =
|
let emit_symbol s =
|
||||||
Emitaux.emit_symbol '$' s
|
Emitaux.emit_symbol '$' s
|
||||||
|
|
||||||
(* Record symbols used and defined - at the end generate extern for those
|
(* Record symbols used and defined - at the end generate extern for those
|
||||||
used but not defined *)
|
used but not defined *)
|
||||||
|
|
||||||
let symbols_defined = ref StringSet.empty
|
let symbols_defined = ref StringSet.empty
|
||||||
|
|
@ -84,11 +84,11 @@ let emit_label lbl =
|
||||||
|
|
||||||
let emit_align n =
|
let emit_align n =
|
||||||
` ALIGN {emit_int n}\n`
|
` ALIGN {emit_int n}\n`
|
||||||
|
|
||||||
let emit_Llabel fallthrough lbl =
|
let emit_Llabel fallthrough lbl =
|
||||||
if not fallthrough && !fastcode_flag then emit_align 4;
|
if not fallthrough && !fastcode_flag then emit_align 4;
|
||||||
emit_label lbl
|
emit_label lbl
|
||||||
|
|
||||||
(* Output a pseudo-register *)
|
(* Output a pseudo-register *)
|
||||||
|
|
||||||
let emit_reg = function
|
let emit_reg = function
|
||||||
|
|
@ -106,13 +106,13 @@ let emit_reg = function
|
||||||
(* Output a reference to the lower 8, 16 or 32 bits of a register *)
|
(* Output a reference to the lower 8, 16 or 32 bits of a register *)
|
||||||
|
|
||||||
let reg_low_8_name =
|
let reg_low_8_name =
|
||||||
[| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b";
|
[| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b";
|
||||||
"r10b"; "r11b"; "bpl"; "r12b"; "r13b" |]
|
"r10b"; "r11b"; "bpl"; "r12b"; "r13b" |]
|
||||||
let reg_low_16_name =
|
let reg_low_16_name =
|
||||||
[| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w";
|
[| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w";
|
||||||
"r10w"; "r11w"; "bp"; "r12w"; "r13w" |]
|
"r10w"; "r11w"; "bp"; "r12w"; "r13w" |]
|
||||||
let reg_low_32_name =
|
let reg_low_32_name =
|
||||||
[| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d";
|
[| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d";
|
||||||
"r10d"; "r11d"; "ebp"; "r12d"; "r13d" |]
|
"r10d"; "r11d"; "ebp"; "r12d"; "r13d" |]
|
||||||
|
|
||||||
let emit_subreg tbl pref r =
|
let emit_subreg tbl pref r =
|
||||||
|
|
@ -253,7 +253,7 @@ let name_for_cond_branch = function
|
||||||
| Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne"
|
| Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne"
|
||||||
| Iunsigned Cle -> "be" | Iunsigned Cgt -> "a"
|
| Iunsigned Cle -> "be" | Iunsigned Cgt -> "a"
|
||||||
| Iunsigned Clt -> "b" | Iunsigned Cge -> "ae"
|
| Iunsigned Clt -> "b" | Iunsigned Cge -> "ae"
|
||||||
|
|
||||||
(* Output an = 0 or <> 0 test. *)
|
(* Output an = 0 or <> 0 test. *)
|
||||||
|
|
||||||
let output_test_zero arg =
|
let output_test_zero arg =
|
||||||
|
|
@ -544,7 +544,7 @@ let emit_instr fallthrough i =
|
||||||
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||||
let b = name_for_cond_branch cmp in
|
let b = name_for_cond_branch cmp in
|
||||||
` j{emit_string b} {emit_label lbl}\n`
|
` j{emit_string b} {emit_label lbl}\n`
|
||||||
| Iinttest_imm((Isigned Ceq | Isigned Cne |
|
| Iinttest_imm((Isigned Ceq | Isigned Cne |
|
||||||
Iunsigned Ceq | Iunsigned Cne) as cmp, 0) ->
|
Iunsigned Ceq | Iunsigned Cne) as cmp, 0) ->
|
||||||
output_test_zero i.arg.(0);
|
output_test_zero i.arg.(0);
|
||||||
let b = name_for_cond_branch cmp in
|
let b = name_for_cond_branch cmp in
|
||||||
|
|
|
||||||
|
|
@ -31,24 +31,24 @@ open Mach
|
||||||
rcx 5
|
rcx 5
|
||||||
r8 6
|
r8 6
|
||||||
r9 7
|
r9 7
|
||||||
r10 8
|
r10 8
|
||||||
r11 9
|
r11 9
|
||||||
rbp 10
|
rbp 10
|
||||||
r12 11
|
r12 11
|
||||||
r13 12
|
r13 12
|
||||||
r14 trap pointer
|
r14 trap pointer
|
||||||
r15 allocation pointer
|
r15 allocation pointer
|
||||||
|
|
||||||
xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments
|
xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments
|
||||||
xmm0 - xmm7: C function arguments
|
xmm0 - xmm7: C function arguments
|
||||||
xmm0: Caml and C function results *)
|
xmm0: Caml and C function results *)
|
||||||
|
|
||||||
let int_reg_name =
|
let int_reg_name =
|
||||||
[| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9";
|
[| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9";
|
||||||
"%r10"; "%r11"; "%rbp"; "%r12"; "%r13" |]
|
"%r10"; "%r11"; "%rbp"; "%r12"; "%r13" |]
|
||||||
|
|
||||||
let float_reg_name =
|
let float_reg_name =
|
||||||
[| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7";
|
[| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7";
|
||||||
"%xmm8"; "%xmm9"; "%xmm10"; "%xmm11";
|
"%xmm8"; "%xmm9"; "%xmm10"; "%xmm11";
|
||||||
"%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |]
|
"%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |]
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -31,25 +31,25 @@ open Mach
|
||||||
rcx 5
|
rcx 5
|
||||||
r8 6
|
r8 6
|
||||||
r9 7
|
r9 7
|
||||||
r10 8
|
r10 8
|
||||||
r11 9
|
r11 9
|
||||||
rbp 10
|
rbp 10
|
||||||
r12 11
|
r12 11
|
||||||
r13 12
|
r13 12
|
||||||
r14 trap pointer
|
r14 trap pointer
|
||||||
r15 allocation pointer
|
r15 allocation pointer
|
||||||
|
|
||||||
xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments
|
xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments
|
||||||
xmm0 - xmm3: C function arguments
|
xmm0 - xmm3: C function arguments
|
||||||
xmm0: Caml and C function results
|
xmm0: Caml and C function results
|
||||||
xmm6-xmm15 are preserved by C *)
|
xmm6-xmm15 are preserved by C *)
|
||||||
|
|
||||||
let int_reg_name =
|
let int_reg_name =
|
||||||
[| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9";
|
[| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9";
|
||||||
"r10"; "r11"; "rbp"; "r12"; "r13" |]
|
"r10"; "r11"; "rbp"; "r12"; "r13" |]
|
||||||
|
|
||||||
let float_reg_name =
|
let float_reg_name =
|
||||||
[| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7";
|
[| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7";
|
||||||
"xmm8"; "xmm9"; "xmm10"; "xmm11"; "xmm12"; "xmm13"; "xmm14"; "xmm15" |]
|
"xmm8"; "xmm9"; "xmm10"; "xmm11"; "xmm12"; "xmm13"; "xmm14"; "xmm15" |]
|
||||||
|
|
||||||
let num_register_classes = 2
|
let num_register_classes = 2
|
||||||
|
|
@ -229,5 +229,5 @@ let contains_calls = ref false
|
||||||
|
|
||||||
let assemble_file infile outfile =
|
let assemble_file infile outfile =
|
||||||
Ccomp.command (Config.asm ^
|
Ccomp.command (Config.asm ^
|
||||||
Filename.quote outfile ^ " " ^
|
Filename.quote outfile ^ " " ^
|
||||||
Filename.quote infile ^ "> NUL")
|
Filename.quote infile ^ "> NUL")
|
||||||
|
|
|
||||||
|
|
@ -274,7 +274,7 @@ let emit_instr i =
|
||||||
` mov {emit_reg i.res.(0)}, #{emit_nativeint low_bits} @ {emit_string s}\n`;
|
` mov {emit_reg i.res.(0)}, #{emit_nativeint low_bits} @ {emit_string s}\n`;
|
||||||
` mov {emit_reg i.res.(1)}, #{emit_nativeint high_bits}\n`;
|
` mov {emit_reg i.res.(1)}, #{emit_nativeint high_bits}\n`;
|
||||||
2
|
2
|
||||||
end else begin
|
end else begin
|
||||||
let lbl = label_constant float_constants s 2 in
|
let lbl = label_constant float_constants s 2 in
|
||||||
` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n`;
|
` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n`;
|
||||||
` ldr {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`;
|
` ldr {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`;
|
||||||
|
|
|
||||||
|
|
@ -166,7 +166,7 @@ method select_operation op args =
|
||||||
method select_condition = function
|
method select_condition = function
|
||||||
| Cop(Ccmpf cmp, args) ->
|
| Cop(Ccmpf cmp, args) ->
|
||||||
(Iinttest_imm(Isigned cmp, 0),
|
(Iinttest_imm(Isigned cmp, 0),
|
||||||
Cop(Cextcall(float_comparison_function cmp,
|
Cop(Cextcall(float_comparison_function cmp,
|
||||||
typ_int, false, Debuginfo.none),
|
typ_int, false, Debuginfo.none),
|
||||||
args))
|
args))
|
||||||
| expr ->
|
| expr ->
|
||||||
|
|
@ -198,4 +198,3 @@ method insert_op_debug op dbg rs rd =
|
||||||
end
|
end
|
||||||
|
|
||||||
let fundecl f = (new selector)#emit_fundecl f
|
let fundecl f = (new selector)#emit_fundecl f
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -90,7 +90,7 @@ let compile_genfuns ppf f =
|
||||||
List.iter
|
List.iter
|
||||||
(function
|
(function
|
||||||
| (Cfunction {fun_name = name}) as ph when f name ->
|
| (Cfunction {fun_name = name}) as ph when f name ->
|
||||||
compile_phrase ppf ph
|
compile_phrase ppf ph
|
||||||
| _ -> ())
|
| _ -> ())
|
||||||
(Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
|
(Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -71,4 +71,3 @@ let report_error ppf = function
|
||||||
fprintf ppf "Cannot find file %s" name
|
fprintf ppf "Cannot find file %s" name
|
||||||
| Archiver_error name ->
|
| Archiver_error name ->
|
||||||
fprintf ppf "Error while creating the library %s" name
|
fprintf ppf "Error while creating the library %s" name
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -83,10 +83,10 @@ let make_package_object ppf members targetobj targetname coercion =
|
||||||
let objtemp =
|
let objtemp =
|
||||||
if !Clflags.keep_asm_file
|
if !Clflags.keep_asm_file
|
||||||
then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj
|
then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj
|
||||||
else
|
else
|
||||||
(* Put the full name of the module in the temporary file name
|
(* Put the full name of the module in the temporary file name
|
||||||
to avoid collisions with MSVC's link /lib in case of successive
|
to avoid collisions with MSVC's link /lib in case of successive
|
||||||
packs *)
|
packs *)
|
||||||
Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in
|
Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in
|
||||||
let components =
|
let components =
|
||||||
List.map
|
List.map
|
||||||
|
|
|
||||||
|
|
@ -15,4 +15,3 @@
|
||||||
(* Introduction of closures, uncurrying, recognition of direct calls *)
|
(* Introduction of closures, uncurrying, recognition of direct calls *)
|
||||||
|
|
||||||
val intro: int -> Lambda.lambda -> Clambda.ulambda
|
val intro: int -> Lambda.lambda -> Clambda.ulambda
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -129,4 +129,3 @@ type data_item =
|
||||||
type phrase =
|
type phrase =
|
||||||
Cfunction of fundecl
|
Cfunction of fundecl
|
||||||
| Cdata of data_item list
|
| Cdata of data_item list
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -115,4 +115,3 @@ type data_item =
|
||||||
type phrase =
|
type phrase =
|
||||||
Cfunction of fundecl
|
Cfunction of fundecl
|
||||||
| Cdata of data_item list
|
| Cdata of data_item list
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1950,9 +1950,9 @@ let generic_functions shared units =
|
||||||
let (apply,send,curry) =
|
let (apply,send,curry) =
|
||||||
List.fold_left
|
List.fold_left
|
||||||
(fun (apply,send,curry) ui ->
|
(fun (apply,send,curry) ui ->
|
||||||
List.fold_right IntSet.add ui.Compilenv.ui_apply_fun apply,
|
List.fold_right IntSet.add ui.Compilenv.ui_apply_fun apply,
|
||||||
List.fold_right IntSet.add ui.Compilenv.ui_send_fun send,
|
List.fold_right IntSet.add ui.Compilenv.ui_send_fun send,
|
||||||
List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry)
|
List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry)
|
||||||
(IntSet.empty,IntSet.empty,IntSet.empty)
|
(IntSet.empty,IntSet.empty,IntSet.empty)
|
||||||
units in
|
units in
|
||||||
let apply = if shared then apply else IntSet.union apply default_apply in
|
let apply = if shared then apply else IntSet.union apply default_apply in
|
||||||
|
|
@ -2071,7 +2071,7 @@ let plugin_header units =
|
||||||
crc = crc;
|
crc = crc;
|
||||||
imports_cmi = ui.Compilenv.ui_imports_cmi;
|
imports_cmi = ui.Compilenv.ui_imports_cmi;
|
||||||
imports_cmx = ui.Compilenv.ui_imports_cmx;
|
imports_cmx = ui.Compilenv.ui_imports_cmx;
|
||||||
defines = ui.Compilenv.ui_defines
|
defines = ui.Compilenv.ui_defines
|
||||||
} in
|
} in
|
||||||
global_data "caml_plugin_header"
|
global_data "caml_plugin_header"
|
||||||
{ magic = dyn_magic_number; units = List.map mk units }
|
{ magic = dyn_magic_number; units = List.map mk units }
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@ val generic_functions: bool -> Compilenv.unit_infos list -> Cmm.phrase list
|
||||||
val entry_point: string list -> Cmm.phrase
|
val entry_point: string list -> Cmm.phrase
|
||||||
val global_table: string list -> Cmm.phrase
|
val global_table: string list -> Cmm.phrase
|
||||||
val reference_symbols: string list -> Cmm.phrase
|
val reference_symbols: string list -> Cmm.phrase
|
||||||
val globals_map: (string * Digest.t * Digest.t * string list) list ->
|
val globals_map: (string * Digest.t * Digest.t * string list) list ->
|
||||||
Cmm.phrase
|
Cmm.phrase
|
||||||
val frame_table: string list -> Cmm.phrase
|
val frame_table: string list -> Cmm.phrase
|
||||||
val data_segment_table: string list -> Cmm.phrase
|
val data_segment_table: string list -> Cmm.phrase
|
||||||
|
|
|
||||||
|
|
@ -39,7 +39,7 @@ let rec regalloc fd =
|
||||||
let (newfd, redo_regalloc) = Reload.fundecl fd in
|
let (newfd, redo_regalloc) = Reload.fundecl fd in
|
||||||
if !dump_reload then
|
if !dump_reload then
|
||||||
Printmach.phase "After insertion of reloading code" newfd;
|
Printmach.phase "After insertion of reloading code" newfd;
|
||||||
if redo_regalloc
|
if redo_regalloc
|
||||||
then begin Reg.reinit(); Liveness.fundecl newfd; regalloc newfd end
|
then begin Reg.reinit(); Liveness.fundecl newfd; regalloc newfd end
|
||||||
else newfd
|
else newfd
|
||||||
|
|
||||||
|
|
@ -95,7 +95,3 @@ let file filename =
|
||||||
close_in ic; Parsecmmaux.report_error msg
|
close_in ic; Parsecmmaux.report_error msg
|
||||||
| x ->
|
| x ->
|
||||||
close_in ic; raise x
|
close_in ic; raise x
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -50,7 +50,7 @@ let find_degree reg =
|
||||||
let cl = Proc.register_class reg in
|
let cl = Proc.register_class reg in
|
||||||
let avail_regs = Proc.num_available_registers.(cl) in
|
let avail_regs = Proc.num_available_registers.(cl) in
|
||||||
if avail_regs = 0 then
|
if avail_regs = 0 then
|
||||||
(* Don't bother computing the degree if there are no regs
|
(* Don't bother computing the degree if there are no regs
|
||||||
in this class *)
|
in this class *)
|
||||||
unconstrained := Reg.Set.add reg !unconstrained
|
unconstrained := Reg.Set.add reg !unconstrained
|
||||||
else begin
|
else begin
|
||||||
|
|
@ -131,7 +131,7 @@ let iter_preferred f reg =
|
||||||
List.iter (fun (r, w) -> walk r w) reg.prefer;
|
List.iter (fun (r, w) -> walk r w) reg.prefer;
|
||||||
reg.visited <- false
|
reg.visited <- false
|
||||||
|
|
||||||
(* Where to start the search for a suitable register.
|
(* Where to start the search for a suitable register.
|
||||||
Used to introduce some "randomness" in the choice between registers
|
Used to introduce some "randomness" in the choice between registers
|
||||||
with equal scores. This offers more opportunities for scheduling. *)
|
with equal scores. This offers more opportunities for scheduling. *)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -179,7 +179,7 @@ let record_global_approx_toplevel id =
|
||||||
let global_approx id =
|
let global_approx id =
|
||||||
if Ident.is_predef_exn id then Value_unknown
|
if Ident.is_predef_exn id then Value_unknown
|
||||||
else try Hashtbl.find toplevel_approx (Ident.name id)
|
else try Hashtbl.find toplevel_approx (Ident.name id)
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
match get_global_info id with
|
match get_global_info id with
|
||||||
| None -> Value_unknown
|
| None -> Value_unknown
|
||||||
| Some ui -> ui.ui_approx
|
| Some ui -> ui.ui_approx
|
||||||
|
|
@ -240,4 +240,3 @@ let report_error ppf = function
|
||||||
fprintf ppf "Corrupted compilation unit description@ %s" filename
|
fprintf ppf "Corrupted compilation unit description@ %s" filename
|
||||||
| Illegal_renaming(modname, filename) ->
|
| Illegal_renaming(modname, filename) ->
|
||||||
fprintf ppf "%s@ contains the description for unit@ %s" filename modname
|
fprintf ppf "%s@ contains the description for unit@ %s" filename modname
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -106,5 +106,3 @@ type error =
|
||||||
exception Error of error
|
exception Error of error
|
||||||
|
|
||||||
val report_error: Format.formatter -> error -> unit
|
val report_error: Format.formatter -> error -> unit
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -33,7 +33,7 @@ let none = {
|
||||||
|
|
||||||
let to_string d =
|
let to_string d =
|
||||||
if d == none
|
if d == none
|
||||||
then ""
|
then ""
|
||||||
else Printf.sprintf "{%s:%d,%d-%d}"
|
else Printf.sprintf "{%s:%d,%d-%d}"
|
||||||
d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end
|
d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -28,4 +28,3 @@ val from_location: kind -> Location.t -> t
|
||||||
|
|
||||||
val from_call: Lambda.lambda_event -> t
|
val from_call: Lambda.lambda_event -> t
|
||||||
val from_raise: Lambda.lambda_event -> t
|
val from_raise: Lambda.lambda_event -> t
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -138,7 +138,7 @@ let emit_frames a =
|
||||||
let filenames = Hashtbl.create 7 in
|
let filenames = Hashtbl.create 7 in
|
||||||
let lbl_filenames = ref 200000 in
|
let lbl_filenames = ref 200000 in
|
||||||
let label_filename name =
|
let label_filename name =
|
||||||
try
|
try
|
||||||
Hashtbl.find filenames name
|
Hashtbl.find filenames name
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
let lbl = !lbl_filenames in
|
let lbl = !lbl_filenames in
|
||||||
|
|
@ -165,7 +165,7 @@ let emit_frames a =
|
||||||
Int64.add (Int64.shift_left (Int64.of_int char_end) 26)
|
Int64.add (Int64.shift_left (Int64.of_int char_end) 26)
|
||||||
(Int64.of_int kind))) in
|
(Int64.of_int kind))) in
|
||||||
a.efa_label_rel
|
a.efa_label_rel
|
||||||
(label_filename d.dinfo_file)
|
(label_filename d.dinfo_file)
|
||||||
(Int64.to_int32 info);
|
(Int64.to_int32 info);
|
||||||
a.efa_32 (Int64.to_int32 (Int64.shift_right info 32))
|
a.efa_32 (Int64.to_int32 (Int64.shift_right info 32))
|
||||||
end in
|
end in
|
||||||
|
|
@ -189,4 +189,3 @@ let is_generic_function name =
|
||||||
List.exists
|
List.exists
|
||||||
(fun p -> isprefix p name)
|
(fun p -> isprefix p name)
|
||||||
["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"]
|
["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"]
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -71,4 +71,3 @@ let print_specific_operation printreg op ppf arg =
|
||||||
| Ishift1add -> fprintf ppf "%a << 1 + %a" printreg arg.(0) printreg arg.(1)
|
| Ishift1add -> fprintf ppf "%a << 1 + %a" printreg arg.(0) printreg arg.(1)
|
||||||
| Ishift2add -> fprintf ppf "%a << 2 + %a" printreg arg.(0) printreg arg.(1)
|
| Ishift2add -> fprintf ppf "%a << 2 + %a" printreg arg.(0) printreg arg.(1)
|
||||||
| Ishift3add -> fprintf ppf "%a << 3 + %a" printreg arg.(0) printreg arg.(1)
|
| Ishift3add -> fprintf ppf "%a << 3 + %a" printreg arg.(0) printreg arg.(1)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -137,7 +137,7 @@ let emit_imports () =
|
||||||
|
|
||||||
let is_offset n = (n < 8192) && (n >= -8192) (* 14 bits *)
|
let is_offset n = (n < 8192) && (n >= -8192) (* 14 bits *)
|
||||||
|
|
||||||
let is_offset_native n =
|
let is_offset_native n =
|
||||||
n < Nativeint.of_int 8192 && n >= Nativeint.of_int (-8192)
|
n < Nativeint.of_int 8192 && n >= Nativeint.of_int (-8192)
|
||||||
|
|
||||||
let emit_load instr addr arg dst =
|
let emit_load instr addr arg dst =
|
||||||
|
|
|
||||||
|
|
@ -40,18 +40,18 @@ open Mach
|
||||||
%fr31 temporary *)
|
%fr31 temporary *)
|
||||||
|
|
||||||
let int_reg_name = [|
|
let int_reg_name = [|
|
||||||
(* 0-4 *) "%r6"; "%r7"; "%r8"; "%r9"; "%r10";
|
(* 0-4 *) "%r6"; "%r7"; "%r8"; "%r9"; "%r10";
|
||||||
(* 5-10 *) "%r11"; "%r12"; "%r13"; "%r14"; "%r15"; "%r16";
|
(* 5-10 *) "%r11"; "%r12"; "%r13"; "%r14"; "%r15"; "%r16";
|
||||||
(* 11-16 *) "%r17"; "%r18"; "%r19"; "%r20"; "%r21"; "%r22";
|
(* 11-16 *) "%r17"; "%r18"; "%r19"; "%r20"; "%r21"; "%r22";
|
||||||
(* 17-20 *) "%r23"; "%r24"; "%r25"; "%r26";
|
(* 17-20 *) "%r23"; "%r24"; "%r25"; "%r26";
|
||||||
(* 21-22 *) "%r28"; "%r29"
|
(* 21-22 *) "%r28"; "%r29"
|
||||||
|]
|
|]
|
||||||
|
|
||||||
let float_reg_name = [|
|
let float_reg_name = [|
|
||||||
(* 100-105 *) "%fr4"; "%fr5"; "%fr6"; "%fr7"; "%fr8"; "%fr9";
|
(* 100-105 *) "%fr4"; "%fr5"; "%fr6"; "%fr7"; "%fr8"; "%fr9";
|
||||||
(* 106-111 *) "%fr10"; "%fr11"; "%fr12"; "%fr13"; "%fr14"; "%fr15";
|
(* 106-111 *) "%fr10"; "%fr11"; "%fr12"; "%fr13"; "%fr14"; "%fr15";
|
||||||
(* 112-117 *) "%fr16"; "%fr17"; "%fr18"; "%fr19"; "%fr20"; "%fr21";
|
(* 112-117 *) "%fr16"; "%fr17"; "%fr18"; "%fr19"; "%fr20"; "%fr21";
|
||||||
(* 118-123 *) "%fr22"; "%fr23"; "%fr24"; "%fr25"; "%fr26"; "%fr27";
|
(* 118-123 *) "%fr22"; "%fr23"; "%fr24"; "%fr25"; "%fr26"; "%fr27";
|
||||||
(* 124-127 *) "%fr28"; "%fr29"; "%fr30"; "%fr31"
|
(* 124-127 *) "%fr28"; "%fr29"; "%fr30"; "%fr31"
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
|
@ -141,7 +141,7 @@ let loc_results res =
|
||||||
let (loc, ofs) = calling_conventions 20 13 100 107 not_supported res in loc
|
let (loc, ofs) = calling_conventions 20 13 100 107 not_supported res in loc
|
||||||
|
|
||||||
(* Calling C functions:
|
(* Calling C functions:
|
||||||
when all arguments are integers, use %r26 - %r23,
|
when all arguments are integers, use %r26 - %r23,
|
||||||
then -52(%r30), -56(%r30), etc.
|
then -52(%r30), -56(%r30), etc.
|
||||||
When some arguments are floats, we handle a couple of cases by hand
|
When some arguments are floats, we handle a couple of cases by hand
|
||||||
and fail otherwise. *)
|
and fail otherwise. *)
|
||||||
|
|
@ -218,7 +218,7 @@ let contains_calls = ref false
|
||||||
|
|
||||||
let assemble_file infile outfile =
|
let assemble_file infile outfile =
|
||||||
Ccomp.command (Config.asm ^ " -o " ^
|
Ccomp.command (Config.asm ^ " -o " ^
|
||||||
Filename.quote outfile ^ " " ^ Filename.quote infile)
|
Filename.quote outfile ^ " " ^ Filename.quote infile)
|
||||||
|
|
||||||
open Clflags;;
|
open Clflags;;
|
||||||
open Config;;
|
open Config;;
|
||||||
|
|
|
||||||
|
|
@ -69,7 +69,7 @@ method select_operation op args =
|
||||||
Cand, Cor, Cxor : never *)
|
Cand, Cor, Cxor : never *)
|
||||||
| (Cmuli, ([arg1; Cconst_int n] as args)) ->
|
| (Cmuli, ([arg1; Cconst_int n] as args)) ->
|
||||||
let l = Misc.log2 n in
|
let l = Misc.log2 n in
|
||||||
if n = 1 lsl l
|
if n = 1 lsl l
|
||||||
then (Iintop_imm(Ilsl, l), [arg1])
|
then (Iintop_imm(Ilsl, l), [arg1])
|
||||||
else (Iintop Imul, args)
|
else (Iintop Imul, args)
|
||||||
| (Cmuli, ([Cconst_int n; arg1] as args)) ->
|
| (Cmuli, ([Cconst_int n; arg1] as args)) ->
|
||||||
|
|
|
||||||
|
|
@ -144,11 +144,10 @@ let print_specific_operation printreg op ppf arg =
|
||||||
if i > 0 then fprintf ppf ", ";
|
if i > 0 then fprintf ppf ", ";
|
||||||
printreg ppf arg.(i)
|
printreg ppf arg.(i)
|
||||||
done
|
done
|
||||||
|
|
||||||
(* Stack alignment constraints *)
|
(* Stack alignment constraints *)
|
||||||
|
|
||||||
let stack_alignment =
|
let stack_alignment =
|
||||||
match Config.system with
|
match Config.system with
|
||||||
| "macosx" -> 16
|
| "macosx" -> 16
|
||||||
| _ -> 4
|
| _ -> 4
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -49,7 +49,7 @@ let slot_offset loc cl =
|
||||||
| Outgoing n ->
|
| Outgoing n ->
|
||||||
assert (n >= 0);
|
assert (n >= 0);
|
||||||
n
|
n
|
||||||
(* Record symbols used and defined - at the end generate extern for those
|
(* Record symbols used and defined - at the end generate extern for those
|
||||||
used but not defined *)
|
used but not defined *)
|
||||||
|
|
||||||
let symbols_defined = ref StringSet.empty
|
let symbols_defined = ref StringSet.empty
|
||||||
|
|
@ -74,7 +74,7 @@ let emit_label lbl =
|
||||||
(* Output an align directive. *)
|
(* Output an align directive. *)
|
||||||
|
|
||||||
let emit_align n = ` ALIGN {emit_int n}\n`
|
let emit_align n = ` ALIGN {emit_int n}\n`
|
||||||
|
|
||||||
(* Output a pseudo-register *)
|
(* Output a pseudo-register *)
|
||||||
|
|
||||||
let emit_reg = function
|
let emit_reg = function
|
||||||
|
|
@ -257,7 +257,7 @@ let name_for_cond_branch = function
|
||||||
| Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne"
|
| Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne"
|
||||||
| Iunsigned Cle -> "be" | Iunsigned Cgt -> "a"
|
| Iunsigned Cle -> "be" | Iunsigned Cgt -> "a"
|
||||||
| Iunsigned Clt -> "b" | Iunsigned Cge -> "ae"
|
| Iunsigned Clt -> "b" | Iunsigned Cge -> "ae"
|
||||||
|
|
||||||
(* Output an = 0 or <> 0 test. *)
|
(* Output an = 0 or <> 0 test. *)
|
||||||
|
|
||||||
let output_test_zero arg =
|
let output_test_zero arg =
|
||||||
|
|
@ -687,7 +687,7 @@ let emit_instr i =
|
||||||
` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`;
|
` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`;
|
||||||
let b = name_for_cond_branch cmp in
|
let b = name_for_cond_branch cmp in
|
||||||
` j{emit_string b} {emit_label lbl}\n`
|
` j{emit_string b} {emit_label lbl}\n`
|
||||||
| Iinttest_imm((Isigned Ceq | Isigned Cne |
|
| Iinttest_imm((Isigned Ceq | Isigned Cne |
|
||||||
Iunsigned Ceq | Iunsigned Cne) as cmp, 0) ->
|
Iunsigned Ceq | Iunsigned Cne) as cmp, 0) ->
|
||||||
output_test_zero i.arg.(0);
|
output_test_zero i.arg.(0);
|
||||||
let b = name_for_cond_branch cmp in
|
let b = name_for_cond_branch cmp in
|
||||||
|
|
|
||||||
|
|
@ -183,4 +183,4 @@ let contains_calls = ref false
|
||||||
let assemble_file infile outfile =
|
let assemble_file infile outfile =
|
||||||
Ccomp.command (Config.asm ^
|
Ccomp.command (Config.asm ^
|
||||||
Filename.quote outfile ^ " " ^ Filename.quote infile ^
|
Filename.quote outfile ^ " " ^ Filename.quote infile ^
|
||||||
(if !Clflags.verbose then "" else ">NUL"))
|
(if !Clflags.verbose then "" else ">NUL"))
|
||||||
|
|
|
||||||
|
|
@ -72,7 +72,7 @@ let rec select_addr exp =
|
||||||
end
|
end
|
||||||
| arg ->
|
| arg ->
|
||||||
(Alinear arg, 0)
|
(Alinear arg, 0)
|
||||||
|
|
||||||
(* C functions to be turned into Ifloatspecial instructions if -ffast-math *)
|
(* C functions to be turned into Ifloatspecial instructions if -ffast-math *)
|
||||||
|
|
||||||
let inline_float_ops =
|
let inline_float_ops =
|
||||||
|
|
@ -310,7 +310,7 @@ method emit_extcall_args env args =
|
||||||
let sz2 = Misc.align sz1 stack_alignment in
|
let sz2 = Misc.align sz1 stack_alignment in
|
||||||
let rec emit_pushes = function
|
let rec emit_pushes = function
|
||||||
| [] ->
|
| [] ->
|
||||||
if sz2 > sz1 then
|
if sz2 > sz1 then
|
||||||
self#insert (Iop (Istackoffset (sz2 - sz1))) [||] [||]
|
self#insert (Iop (Istackoffset (sz2 - sz1))) [||] [||]
|
||||||
| e :: el ->
|
| e :: el ->
|
||||||
emit_pushes el;
|
emit_pushes el;
|
||||||
|
|
@ -324,4 +324,3 @@ method emit_extcall_args env args =
|
||||||
end
|
end
|
||||||
|
|
||||||
let fundecl f = (new selector)#emit_fundecl f
|
let fundecl f = (new selector)#emit_fundecl f
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -347,7 +347,7 @@ let insimm opc arg imm res =
|
||||||
for i = 0 to Array.length arg - 1 do
|
for i = 0 to Array.length arg - 1 do
|
||||||
Hashtbl.add code_uses arg.(i) node
|
Hashtbl.add code_uses arg.(i) node
|
||||||
done;
|
done;
|
||||||
(* Insert in appropriate queue *)
|
(* Insert in appropriate queue *)
|
||||||
if node.instr.kind = KB
|
if node.instr.kind = KB
|
||||||
then add_branch node
|
then add_branch node
|
||||||
else if node.ancestors = 0 then add_ready node
|
else if node.ancestors = 0 then add_ready node
|
||||||
|
|
@ -359,7 +359,7 @@ let insert opc arg res =
|
||||||
|
|
||||||
let rec longest_path node =
|
let rec longest_path node =
|
||||||
if node.length < 0 then begin
|
if node.length < 0 then begin
|
||||||
node.length <-
|
node.length <-
|
||||||
List.fold_left
|
List.fold_left
|
||||||
(fun len (son, delay) -> max len (longest_path son + delay))
|
(fun len (son, delay) -> max len (longest_path son + delay))
|
||||||
0 node.sons
|
0 node.sons
|
||||||
|
|
@ -447,10 +447,10 @@ let can_issue instr =
|
||||||
| KF ->
|
| KF ->
|
||||||
if !num_F < 2 then (incr num_F; true) else false
|
if !num_F < 2 then (incr num_F; true) else false
|
||||||
| KI ->
|
| KI ->
|
||||||
if !num_I < 2 && !num_A + !num_I + !num_M < 4
|
if !num_I < 2 && !num_A + !num_I + !num_M < 4
|
||||||
then (incr num_I; true) else false
|
then (incr num_I; true) else false
|
||||||
| KM ->
|
| KM ->
|
||||||
if !num_M < 2 && !num_A + !num_I + !num_M < 4
|
if !num_M < 2 && !num_A + !num_I + !num_M < 4
|
||||||
then (incr num_M; true) else false
|
then (incr num_M; true) else false
|
||||||
| _ (* KB | KB_exc *) ->
|
| _ (* KB | KB_exc *) ->
|
||||||
if !num_B < 3 then (incr num_B; true) else false
|
if !num_B < 3 then (incr num_B; true) else false
|
||||||
|
|
@ -481,7 +481,7 @@ let emit_node date node =
|
||||||
end)
|
end)
|
||||||
node.sons
|
node.sons
|
||||||
|
|
||||||
(* Emit all ready nodes that we can emit given the architectural
|
(* Emit all ready nodes that we can emit given the architectural
|
||||||
constraints. *)
|
constraints. *)
|
||||||
|
|
||||||
let rec emit_ready_nodes filter date =
|
let rec emit_ready_nodes filter date =
|
||||||
|
|
@ -561,7 +561,7 @@ let end_basic_block () =
|
||||||
(* Compute critical paths and rebuild ready queue sorted by
|
(* Compute critical paths and rebuild ready queue sorted by
|
||||||
decreasing criticality *)
|
decreasing criticality *)
|
||||||
let r = !ready_queue in
|
let r = !ready_queue in
|
||||||
ready_queue := [];
|
ready_queue := [];
|
||||||
let max_length =
|
let max_length =
|
||||||
List.fold_left (fun len node -> max len (longest_path node)) 0 r in
|
List.fold_left (fun len node -> max len (longest_path node)) 0 r in
|
||||||
List.iter add_ready r;
|
List.iter add_ready r;
|
||||||
|
|
@ -760,7 +760,7 @@ let is_immediate_adds n = n >= -0x2000 && n < 0x2000
|
||||||
|
|
||||||
let ones_pos n =
|
let ones_pos n =
|
||||||
let rec ones p accu =
|
let rec ones p accu =
|
||||||
if p >= 63
|
if p >= 63
|
||||||
then accu
|
then accu
|
||||||
else ones (p+1) (if n land (1 lsl p) = 0 then accu else p :: accu) in
|
else ones (p+1) (if n land (1 lsl p) = 0 then accu else p :: accu) in
|
||||||
ones 0 []
|
ones 0 []
|
||||||
|
|
@ -795,7 +795,7 @@ let emit_instr i =
|
||||||
Lend -> ()
|
Lend -> ()
|
||||||
| Lop(Imove | Ispill | Ireload) ->
|
| Lop(Imove | Ispill | Ireload) ->
|
||||||
let src = i.arg.(0) and dst = i.res.(0) in
|
let src = i.arg.(0) and dst = i.res.(0) in
|
||||||
if src.loc <> dst.loc then begin
|
if src.loc <> dst.loc then begin
|
||||||
match (src.loc, dst.loc) with
|
match (src.loc, dst.loc) with
|
||||||
(Reg _, Reg _) ->
|
(Reg _, Reg _) ->
|
||||||
insert "mov" (regs i.arg) (regs i.res)
|
insert "mov" (regs i.arg) (regs i.res)
|
||||||
|
|
@ -1198,7 +1198,7 @@ let emit_instr i =
|
||||||
| Lpushtrap ->
|
| Lpushtrap ->
|
||||||
end_basic_block();
|
end_basic_block();
|
||||||
stack_offset := !stack_offset + 16;
|
stack_offset := !stack_offset + 16;
|
||||||
(* Store trap pointer at sp, handler addr at sp+8,
|
(* Store trap pointer at sp, handler addr at sp+8,
|
||||||
and decrement sp by 16. Remember, the bottom 16 bytes
|
and decrement sp by 16. Remember, the bottom 16 bytes
|
||||||
of the stack must be left free. *)
|
of the stack must be left free. *)
|
||||||
` add r3 = 8, sp\n`;
|
` add r3 = 8, sp\n`;
|
||||||
|
|
|
||||||
|
|
@ -71,10 +71,10 @@ let int_reg_name = [|
|
||||||
"r88"; "r89"; "r90"; "r91";
|
"r88"; "r89"; "r90"; "r91";
|
||||||
(* 80-81 *) "r14"; "r15"
|
(* 80-81 *) "r14"; "r15"
|
||||||
|]
|
|]
|
||||||
|
|
||||||
let float_reg_name = [|
|
let float_reg_name = [|
|
||||||
(* 0-13 *) "f2"; "f3"; "f4"; "f5"; "f6"; "f7";
|
(* 0-13 *) "f2"; "f3"; "f4"; "f5"; "f6"; "f7";
|
||||||
"f8"; "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15";
|
"f8"; "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15";
|
||||||
(* 14-29 *) "f16"; "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23";
|
(* 14-29 *) "f16"; "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23";
|
||||||
"f24"; "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31";
|
"f24"; "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31";
|
||||||
(* 30-61 *) "f32"; "f33"; "f34"; "f35"; "f36"; "f37"; "f38"; "f39";
|
(* 30-61 *) "f32"; "f33"; "f34"; "f35"; "f36"; "f37"; "f38"; "f39";
|
||||||
|
|
|
||||||
|
|
@ -14,7 +14,7 @@
|
||||||
|
|
||||||
open Schedgen (* to create a dependency *)
|
open Schedgen (* to create a dependency *)
|
||||||
|
|
||||||
(* We don't schedule here on the linearized code, but instead schedule the
|
(* We don't schedule here on the linearized code, but instead schedule the
|
||||||
assembly code generated in Emit. *)
|
assembly code generated in Emit. *)
|
||||||
|
|
||||||
let fundecl f = f
|
let fundecl f = f
|
||||||
|
|
|
||||||
|
|
@ -106,7 +106,7 @@ method select_operation op args =
|
||||||
Turn general division and modulus into calls to C library functions *)
|
Turn general division and modulus into calls to C library functions *)
|
||||||
| (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
| (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||||
(Iintop_imm(Idiv, n), [arg])
|
(Iintop_imm(Idiv, n), [arg])
|
||||||
| (Cdivi, _) ->
|
| (Cdivi, _) ->
|
||||||
(Iextcall("__divdi3", false), args)
|
(Iextcall("__divdi3", false), args)
|
||||||
| (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) && n <> 1 ->
|
| (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) && n <> 1 ->
|
||||||
(Iintop_imm(Imod, n), [arg])
|
(Iintop_imm(Imod, n), [arg])
|
||||||
|
|
|
||||||
|
|
@ -98,7 +98,7 @@ let build_graph fundecl =
|
||||||
| Iexit _ ->
|
| Iexit _ ->
|
||||||
()
|
()
|
||||||
| Itrywith(body, handler) ->
|
| Itrywith(body, handler) ->
|
||||||
add_interf_set Proc.destroyed_at_raise handler.live;
|
add_interf_set Proc.destroyed_at_raise handler.live;
|
||||||
interf body; interf handler; interf i.next
|
interf body; interf handler; interf i.next
|
||||||
| Iraise -> () in
|
| Iraise -> () in
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -49,7 +49,7 @@ and instruction_desc =
|
||||||
let has_fallthrough = function
|
let has_fallthrough = function
|
||||||
| Lreturn | Lbranch _ | Lswitch _ | Lraise
|
| Lreturn | Lbranch _ | Lswitch _ | Lraise
|
||||||
| Lop Itailcall_ind | Lop (Itailcall_imm _) -> false
|
| Lop Itailcall_ind | Lop (Itailcall_imm _) -> false
|
||||||
| _ -> true
|
| _ -> true
|
||||||
|
|
||||||
type fundecl =
|
type fundecl =
|
||||||
{ fun_name: string;
|
{ fun_name: string;
|
||||||
|
|
@ -84,13 +84,13 @@ let rec end_instr =
|
||||||
(* Cons an instruction (live, debug empty) *)
|
(* Cons an instruction (live, debug empty) *)
|
||||||
|
|
||||||
let instr_cons d a r n =
|
let instr_cons d a r n =
|
||||||
{ desc = d; next = n; arg = a; res = r;
|
{ desc = d; next = n; arg = a; res = r;
|
||||||
dbg = Debuginfo.none; live = Reg.Set.empty }
|
dbg = Debuginfo.none; live = Reg.Set.empty }
|
||||||
|
|
||||||
(* Cons a simple instruction (arg, res, live empty) *)
|
(* Cons a simple instruction (arg, res, live empty) *)
|
||||||
|
|
||||||
let cons_instr d n =
|
let cons_instr d n =
|
||||||
{ desc = d; next = n; arg = [||]; res = [||];
|
{ desc = d; next = n; arg = [||]; res = [||];
|
||||||
dbg = Debuginfo.none; live = Reg.Set.empty }
|
dbg = Debuginfo.none; live = Reg.Set.empty }
|
||||||
|
|
||||||
(* Build an instruction with arg, res, dbg, live taken from
|
(* Build an instruction with arg, res, dbg, live taken from
|
||||||
|
|
@ -98,7 +98,7 @@ let cons_instr d n =
|
||||||
|
|
||||||
let copy_instr d i n =
|
let copy_instr d i n =
|
||||||
{ desc = d; next = n;
|
{ desc = d; next = n;
|
||||||
arg = i.Mach.arg; res = i.Mach.res;
|
arg = i.Mach.arg; res = i.Mach.res;
|
||||||
dbg = i.Mach.dbg; live = i.Mach.live }
|
dbg = i.Mach.dbg; live = i.Mach.live }
|
||||||
|
|
||||||
(*
|
(*
|
||||||
|
|
@ -187,7 +187,7 @@ let rec linear i n =
|
||||||
copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1)
|
copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1)
|
||||||
| _, Iend, Lbranch lbl ->
|
| _, Iend, Lbranch lbl ->
|
||||||
copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1)
|
copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1)
|
||||||
| Iexit nfail1, Iexit nfail2, _
|
| Iexit nfail1, Iexit nfail2, _
|
||||||
when is_next_catch nfail1 ->
|
when is_next_catch nfail1 ->
|
||||||
let lbl2 = find_exit_label nfail2 in
|
let lbl2 = find_exit_label nfail2 in
|
||||||
copy_instr
|
copy_instr
|
||||||
|
|
|
||||||
|
|
@ -42,7 +42,7 @@ and instruction_desc =
|
||||||
|
|
||||||
val has_fallthrough : instruction_desc -> bool
|
val has_fallthrough : instruction_desc -> bool
|
||||||
val end_instr: instruction
|
val end_instr: instruction
|
||||||
val instr_cons:
|
val instr_cons:
|
||||||
instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction
|
instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction
|
||||||
val invert_test: Mach.test -> Mach.test
|
val invert_test: Mach.test -> Mach.test
|
||||||
|
|
||||||
|
|
@ -52,4 +52,3 @@ type fundecl =
|
||||||
fun_fast: bool }
|
fun_fast: bool }
|
||||||
|
|
||||||
val fundecl: Mach.fundecl -> fundecl
|
val fundecl: Mach.fundecl -> fundecl
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -82,23 +82,23 @@ type fundecl =
|
||||||
fun_fast: bool }
|
fun_fast: bool }
|
||||||
|
|
||||||
let rec dummy_instr =
|
let rec dummy_instr =
|
||||||
{ desc = Iend;
|
{ desc = Iend;
|
||||||
next = dummy_instr;
|
next = dummy_instr;
|
||||||
arg = [||];
|
arg = [||];
|
||||||
res = [||];
|
res = [||];
|
||||||
dbg = Debuginfo.none;
|
dbg = Debuginfo.none;
|
||||||
live = Reg.Set.empty }
|
live = Reg.Set.empty }
|
||||||
|
|
||||||
let end_instr () =
|
let end_instr () =
|
||||||
{ desc = Iend;
|
{ desc = Iend;
|
||||||
next = dummy_instr;
|
next = dummy_instr;
|
||||||
arg = [||];
|
arg = [||];
|
||||||
res = [||];
|
res = [||];
|
||||||
dbg = Debuginfo.none;
|
dbg = Debuginfo.none;
|
||||||
live = Reg.Set.empty }
|
live = Reg.Set.empty }
|
||||||
|
|
||||||
let instr_cons d a r n =
|
let instr_cons d a r n =
|
||||||
{ desc = d; next = n; arg = a; res = r;
|
{ desc = d; next = n; arg = a; res = r;
|
||||||
dbg = Debuginfo.none; live = Reg.Set.empty }
|
dbg = Debuginfo.none; live = Reg.Set.empty }
|
||||||
|
|
||||||
let instr_cons_debug d a r dbg n =
|
let instr_cons_debug d a r dbg n =
|
||||||
|
|
@ -128,5 +128,4 @@ let rec instr_iter f i =
|
||||||
instr_iter f body; instr_iter f handler; instr_iter f i.next
|
instr_iter f body; instr_iter f handler; instr_iter f i.next
|
||||||
| Iraise -> ()
|
| Iraise -> ()
|
||||||
| _ ->
|
| _ ->
|
||||||
instr_iter f i.next
|
instr_iter f i.next
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -71,7 +71,7 @@ and instruction_desc =
|
||||||
| Iswitch of int array * instruction array
|
| Iswitch of int array * instruction array
|
||||||
| Iloop of instruction
|
| Iloop of instruction
|
||||||
| Icatch of int * instruction * instruction
|
| Icatch of int * instruction * instruction
|
||||||
| Iexit of int
|
| Iexit of int
|
||||||
| Itrywith of instruction * instruction
|
| Itrywith of instruction * instruction
|
||||||
| Iraise
|
| Iraise
|
||||||
|
|
||||||
|
|
@ -83,11 +83,10 @@ type fundecl =
|
||||||
|
|
||||||
val dummy_instr: instruction
|
val dummy_instr: instruction
|
||||||
val end_instr: unit -> instruction
|
val end_instr: unit -> instruction
|
||||||
val instr_cons:
|
val instr_cons:
|
||||||
instruction_desc -> Reg.t array -> Reg.t array -> instruction ->
|
instruction_desc -> Reg.t array -> Reg.t array -> instruction ->
|
||||||
instruction
|
instruction
|
||||||
val instr_cons_debug:
|
val instr_cons_debug:
|
||||||
instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t ->
|
instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t ->
|
||||||
instruction -> instruction
|
instruction -> instruction
|
||||||
val instr_iter: (instruction -> unit) -> instruction -> unit
|
val instr_iter: (instruction -> unit) -> instruction -> unit
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -94,7 +94,7 @@ let emit_addressing addr r n =
|
||||||
|
|
||||||
let int_reg_number =
|
let int_reg_number =
|
||||||
[| 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21 |]
|
[| 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21 |]
|
||||||
|
|
||||||
let float_reg_number =
|
let float_reg_number =
|
||||||
[| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19;
|
[| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19;
|
||||||
20; 21; 22; 23; 24; 25; 26; 27; 28; 29; 30 |]
|
20; 21; 22; 23; 24; 25; 26; 27; 28; 29; 30 |]
|
||||||
|
|
|
||||||
|
|
@ -50,7 +50,7 @@ let int_reg_name = [|
|
||||||
(* 6-13 *) "$8"; "$9"; "$10"; "$11"; "$12"; "$13"; "$14"; "$15";
|
(* 6-13 *) "$8"; "$9"; "$10"; "$11"; "$12"; "$13"; "$14"; "$15";
|
||||||
(* 14-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21"
|
(* 14-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21"
|
||||||
|]
|
|]
|
||||||
|
|
||||||
let float_reg_name = [|
|
let float_reg_name = [|
|
||||||
"$f0"; "$f1"; "$f2"; "$f3"; "$f4";
|
"$f0"; "$f1"; "$f2"; "$f3"; "$f4";
|
||||||
"$f5"; "$f6"; "$f7"; "$f8"; "$f9";
|
"$f5"; "$f6"; "$f7"; "$f8"; "$f9";
|
||||||
|
|
@ -143,7 +143,7 @@ let loc_results res =
|
||||||
or float regs $f12...$f19. Each argument "consumes" both one slot
|
or float regs $f12...$f19. Each argument "consumes" both one slot
|
||||||
in the int register file and one slot in the float register file.
|
in the int register file and one slot in the float register file.
|
||||||
Extra arguments are passed on stack, in a 64-bits slot, right-justified
|
Extra arguments are passed on stack, in a 64-bits slot, right-justified
|
||||||
(i.e. at +4 from natural address). *)
|
(i.e. at +4 from natural address). *)
|
||||||
|
|
||||||
let loc_external_arguments arg =
|
let loc_external_arguments arg =
|
||||||
let loc = Array.create (Array.length arg) Reg.dummy in
|
let loc = Array.create (Array.length arg) Reg.dummy in
|
||||||
|
|
|
||||||
|
|
@ -84,4 +84,3 @@ let print_specific_operation printreg op ppf arg =
|
||||||
printreg arg.(0) printreg arg.(1) printreg arg.(2)
|
printreg arg.(0) printreg arg.(1) printreg arg.(2)
|
||||||
| Ialloc_far n ->
|
| Ialloc_far n ->
|
||||||
fprintf ppf "alloc_far %d" n
|
fprintf ppf "alloc_far %d" n
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -116,7 +116,7 @@ let emit_reg r =
|
||||||
Reg r -> emit_string (register_name r)
|
Reg r -> emit_string (register_name r)
|
||||||
| _ -> fatal_error "Emit.emit_reg"
|
| _ -> fatal_error "Emit.emit_reg"
|
||||||
|
|
||||||
let use_full_regnames =
|
let use_full_regnames =
|
||||||
Config.system = "rhapsody"
|
Config.system = "rhapsody"
|
||||||
|
|
||||||
let emit_gpr r =
|
let emit_gpr r =
|
||||||
|
|
@ -607,13 +607,13 @@ let rec emit_instr i dslot =
|
||||||
| Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *)
|
| Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *)
|
||||||
let l = Misc.log2 n in
|
let l = Misc.log2 n in
|
||||||
` {emit_string sragi} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`;
|
` {emit_string sragi} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`;
|
||||||
` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
|
` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
|
||||||
| Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *)
|
| Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *)
|
||||||
let l = Misc.log2 n in
|
let l = Misc.log2 n in
|
||||||
` {emit_string sragi} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`;
|
` {emit_string sragi} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`;
|
||||||
` addze {emit_gpr 0}, {emit_gpr 0}\n`;
|
` addze {emit_gpr 0}, {emit_gpr 0}\n`;
|
||||||
` {emit_string slgi} {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`;
|
` {emit_string slgi} {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`;
|
||||||
` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n`
|
` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n`
|
||||||
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
||||||
begin match cmp with
|
begin match cmp with
|
||||||
Isigned c ->
|
Isigned c ->
|
||||||
|
|
|
||||||
|
|
@ -45,14 +45,14 @@ let word_addressed = false
|
||||||
|
|
||||||
let int_reg_name =
|
let int_reg_name =
|
||||||
if Config.system = "rhapsody" then
|
if Config.system = "rhapsody" then
|
||||||
[| "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "r10";
|
[| "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "r10";
|
||||||
"r14"; "r15"; "r16"; "r17"; "r18"; "r19"; "r20"; "r21";
|
"r14"; "r15"; "r16"; "r17"; "r18"; "r19"; "r20"; "r21";
|
||||||
"r22"; "r23"; "r24"; "r25"; "r26"; "r27"; "r28" |]
|
"r22"; "r23"; "r24"; "r25"; "r26"; "r27"; "r28" |]
|
||||||
else
|
else
|
||||||
[| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10";
|
[| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10";
|
||||||
"14"; "15"; "16"; "17"; "18"; "19"; "20"; "21";
|
"14"; "15"; "16"; "17"; "18"; "19"; "20"; "21";
|
||||||
"22"; "23"; "24"; "25"; "26"; "27"; "28" |]
|
"22"; "23"; "24"; "25"; "26"; "27"; "28" |]
|
||||||
|
|
||||||
let float_reg_name =
|
let float_reg_name =
|
||||||
if Config.system = "rhapsody" then
|
if Config.system = "rhapsody" then
|
||||||
[| "f1"; "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; "f8";
|
[| "f1"; "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; "f8";
|
||||||
|
|
|
||||||
|
|
@ -63,4 +63,3 @@ method reload_retaddr_issue_cycles = 3
|
||||||
end
|
end
|
||||||
|
|
||||||
let fundecl f = (new scheduler)#schedule_fundecl f
|
let fundecl f = (new scheduler)#schedule_fundecl f
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -69,7 +69,7 @@ method select_operation op args =
|
||||||
a power of 2, which do not correspond to an instruction. *)
|
a power of 2, which do not correspond to an instruction. *)
|
||||||
(Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
(Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||||
(Iintop_imm(Idiv, n), [arg])
|
(Iintop_imm(Idiv, n), [arg])
|
||||||
| (Cdivi, _) ->
|
| (Cdivi, _) ->
|
||||||
(Iintop Idiv, args)
|
(Iintop Idiv, args)
|
||||||
| (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
| (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
|
||||||
(Iintop_imm(Imod, n), [arg])
|
(Iintop_imm(Imod, n), [arg])
|
||||||
|
|
|
||||||
|
|
@ -108,7 +108,7 @@ let rec expr ppf = function
|
||||||
| Clet(id, def, body) ->
|
| Clet(id, def, body) ->
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[<2>(let@ @[<2>%a@ %a@]@ %a)@]"
|
"@[<2>(let@ @[<2>%a@ %a@]@ %a)@]"
|
||||||
Ident.print id expr def sequence body
|
Ident.print id expr def sequence body
|
||||||
| Cassign(id, exp) ->
|
| Cassign(id, exp) ->
|
||||||
fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp
|
fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp
|
||||||
| Ctuple el ->
|
| Ctuple el ->
|
||||||
|
|
@ -142,7 +142,7 @@ let rec expr ppf = function
|
||||||
for i = 0 to Array.length cases - 1 do
|
for i = 0 to Array.length cases - 1 do
|
||||||
fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i)
|
fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i)
|
||||||
done in
|
done in
|
||||||
fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases
|
fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases
|
||||||
| Cloop e ->
|
| Cloop e ->
|
||||||
fprintf ppf "@[<2>(loop@ %a)@]" sequence e
|
fprintf ppf "@[<2>(loop@ %a)@]" sequence e
|
||||||
| Ccatch(i, ids, e1, e2) ->
|
| Ccatch(i, ids, e1, e2) ->
|
||||||
|
|
@ -172,7 +172,7 @@ let fundecl ppf f =
|
||||||
let print_cases ppf cases =
|
let print_cases ppf cases =
|
||||||
let first = ref true in
|
let first = ref true in
|
||||||
List.iter
|
List.iter
|
||||||
(fun (id, ty) ->
|
(fun (id, ty) ->
|
||||||
if !first then first := false else fprintf ppf "@ ";
|
if !first then first := false else fprintf ppf "@ ";
|
||||||
fprintf ppf "%a: %a" Ident.print id machtype ty)
|
fprintf ppf "%a: %a" Ident.print id machtype ty)
|
||||||
cases in
|
cases in
|
||||||
|
|
|
||||||
|
|
@ -27,7 +27,7 @@ let reg ppf r =
|
||||||
fprintf ppf "/%i" r.stamp;
|
fprintf ppf "/%i" r.stamp;
|
||||||
begin match r.loc with
|
begin match r.loc with
|
||||||
| Unknown -> ()
|
| Unknown -> ()
|
||||||
| Reg r ->
|
| Reg r ->
|
||||||
fprintf ppf "[%s]" (Proc.register_name r)
|
fprintf ppf "[%s]" (Proc.register_name r)
|
||||||
| Stack(Local s) ->
|
| Stack(Local s) ->
|
||||||
fprintf ppf "[s%i]" s
|
fprintf ppf "[s%i]" s
|
||||||
|
|
|
||||||
|
|
@ -82,7 +82,7 @@ let first_virtual_reg_stamp = ref (-1)
|
||||||
let reset() =
|
let reset() =
|
||||||
(* When reset() is called for the first time, the current stamp reflects
|
(* When reset() is called for the first time, the current stamp reflects
|
||||||
all hard pseudo-registers that have been allocated by Proc, so
|
all hard pseudo-registers that have been allocated by Proc, so
|
||||||
remember it and use it as the base stamp for allocating
|
remember it and use it as the base stamp for allocating
|
||||||
soft pseudo-registers *)
|
soft pseudo-registers *)
|
||||||
if !first_virtual_reg_stamp = -1 then first_virtual_reg_stamp := !currstamp;
|
if !first_virtual_reg_stamp = -1 then first_virtual_reg_stamp := !currstamp;
|
||||||
currstamp := !first_virtual_reg_stamp;
|
currstamp := !first_virtual_reg_stamp;
|
||||||
|
|
|
||||||
|
|
@ -15,4 +15,3 @@
|
||||||
(* Insert load/stores for pseudoregs that got assigned to stack locations. *)
|
(* Insert load/stores for pseudoregs that got assigned to stack locations. *)
|
||||||
|
|
||||||
val fundecl: Mach.fundecl -> Mach.fundecl * bool
|
val fundecl: Mach.fundecl -> Mach.fundecl * bool
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -109,13 +109,13 @@ method private reload i =
|
||||||
(self#reload i.next))}
|
(self#reload i.next))}
|
||||||
| Iifthenelse(tst, ifso, ifnot) ->
|
| Iifthenelse(tst, ifso, ifnot) ->
|
||||||
let newarg = self#reload_test tst i.arg in
|
let newarg = self#reload_test tst i.arg in
|
||||||
insert_moves i.arg newarg
|
insert_moves i.arg newarg
|
||||||
(instr_cons
|
(instr_cons
|
||||||
(Iifthenelse(tst, self#reload ifso, self#reload ifnot)) newarg [||]
|
(Iifthenelse(tst, self#reload ifso, self#reload ifnot)) newarg [||]
|
||||||
(self#reload i.next))
|
(self#reload i.next))
|
||||||
| Iswitch(index, cases) ->
|
| Iswitch(index, cases) ->
|
||||||
let newarg = self#makeregs i.arg in
|
let newarg = self#makeregs i.arg in
|
||||||
insert_moves i.arg newarg
|
insert_moves i.arg newarg
|
||||||
(instr_cons (Iswitch(index, Array.map (self#reload) cases)) newarg [||]
|
(instr_cons (Iswitch(index, Array.map (self#reload) cases)) newarg [||]
|
||||||
(self#reload i.next))
|
(self#reload i.next))
|
||||||
| Iloop body ->
|
| Iloop body ->
|
||||||
|
|
|
||||||
|
|
@ -91,7 +91,7 @@ let rec longest_path critical_outputs node =
|
||||||
then node.delay
|
then node.delay
|
||||||
else 0
|
else 0
|
||||||
| sons ->
|
| sons ->
|
||||||
node.length <-
|
node.length <-
|
||||||
List.fold_left
|
List.fold_left
|
||||||
(fun len (son, delay) ->
|
(fun len (son, delay) ->
|
||||||
max len (longest_path critical_outputs son + delay))
|
max len (longest_path critical_outputs son + delay))
|
||||||
|
|
@ -287,7 +287,7 @@ method private ready_instruction date queue =
|
||||||
then instr else best in
|
then instr else best in
|
||||||
extract new_best rem in
|
extract new_best rem in
|
||||||
extract dummy_node queue
|
extract dummy_node queue
|
||||||
|
|
||||||
(* Schedule a basic block, adding its instructions in front of the given
|
(* Schedule a basic block, adding its instructions in front of the given
|
||||||
instruction sequence *)
|
instruction sequence *)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -259,8 +259,8 @@ method select_operation op args =
|
||||||
| (Cnegf, _) -> (Inegf, args)
|
| (Cnegf, _) -> (Inegf, args)
|
||||||
| (Cabsf, _) -> (Iabsf, args)
|
| (Cabsf, _) -> (Iabsf, args)
|
||||||
| (Caddf, _) -> (Iaddf, args)
|
| (Caddf, _) -> (Iaddf, args)
|
||||||
| (Csubf, _) -> (Isubf, args)
|
| (Csubf, _) -> (Isubf, args)
|
||||||
| (Cmulf, _) -> (Imulf, args)
|
| (Cmulf, _) -> (Imulf, args)
|
||||||
| (Cdivf, _) -> (Idivf, args)
|
| (Cdivf, _) -> (Idivf, args)
|
||||||
| (Cfloatofint, _) -> (Ifloatofint, args)
|
| (Cfloatofint, _) -> (Ifloatofint, args)
|
||||||
| (Cintoffloat, _) -> (Iintoffloat, args)
|
| (Cintoffloat, _) -> (Iintoffloat, args)
|
||||||
|
|
@ -381,7 +381,7 @@ method insert_move_results loc res stacksize =
|
||||||
self#insert_moves loc res
|
self#insert_moves loc res
|
||||||
|
|
||||||
(* Add an Iop opcode. Can be overriden by processor description
|
(* Add an Iop opcode. Can be overriden by processor description
|
||||||
to insert moves before and after the operation, i.e. for two-address
|
to insert moves before and after the operation, i.e. for two-address
|
||||||
instructions, or instructions using dedicated registers. *)
|
instructions, or instructions using dedicated registers. *)
|
||||||
|
|
||||||
method insert_op_debug op dbg rs rd =
|
method insert_op_debug op dbg rs rd =
|
||||||
|
|
@ -506,7 +506,7 @@ method emit_expr env exp =
|
||||||
let r1 = self#emit_tuple env new_args in
|
let r1 = self#emit_tuple env new_args in
|
||||||
let rd = self#regs_for ty in
|
let rd = self#regs_for ty in
|
||||||
Some (self#insert_op_debug op dbg r1 rd)
|
Some (self#insert_op_debug op dbg r1 rd)
|
||||||
end
|
end
|
||||||
| Csequence(e1, e2) ->
|
| Csequence(e1, e2) ->
|
||||||
begin match self#emit_expr env e1 with
|
begin match self#emit_expr env e1 with
|
||||||
None -> None
|
None -> None
|
||||||
|
|
@ -545,7 +545,7 @@ method emit_expr env exp =
|
||||||
(fun id ->
|
(fun id ->
|
||||||
let r = self#regs_for typ_addr in name_regs id r; r)
|
let r = self#regs_for typ_addr in name_regs id r; r)
|
||||||
ids in
|
ids in
|
||||||
catch_regs := (nfail, Array.concat rs) :: !catch_regs ;
|
catch_regs := (nfail, Array.concat rs) :: !catch_regs ;
|
||||||
let (r1, s1) = self#emit_sequence env e1 in
|
let (r1, s1) = self#emit_sequence env e1 in
|
||||||
catch_regs := List.tl !catch_regs ;
|
catch_regs := List.tl !catch_regs ;
|
||||||
let new_env =
|
let new_env =
|
||||||
|
|
@ -768,7 +768,7 @@ method emit_tail env exp =
|
||||||
name_regs id r ;
|
name_regs id r ;
|
||||||
r)
|
r)
|
||||||
ids in
|
ids in
|
||||||
catch_regs := (nfail, Array.concat rs) :: !catch_regs ;
|
catch_regs := (nfail, Array.concat rs) :: !catch_regs ;
|
||||||
let s1 = self#emit_tail_sequence env e1 in
|
let s1 = self#emit_tail_sequence env e1 in
|
||||||
catch_regs := List.tl !catch_regs ;
|
catch_regs := List.tl !catch_regs ;
|
||||||
let new_env =
|
let new_env =
|
||||||
|
|
|
||||||
|
|
@ -62,7 +62,7 @@ class virtual selector_generic : object
|
||||||
|
|
||||||
(* The following method is the entry point and should not be overriden *)
|
(* The following method is the entry point and should not be overriden *)
|
||||||
method emit_fundecl : Cmm.fundecl -> Mach.fundecl
|
method emit_fundecl : Cmm.fundecl -> Mach.fundecl
|
||||||
|
|
||||||
(* The following methods should not be overriden. They cannot be
|
(* The following methods should not be overriden. They cannot be
|
||||||
declared "private" in the current implementation because they
|
declared "private" in the current implementation because they
|
||||||
are not always applied to "self", but ideally they should be private. *)
|
are not always applied to "self", but ideally they should be private. *)
|
||||||
|
|
|
||||||
|
|
@ -50,7 +50,7 @@ let int_reg_name = [|
|
||||||
(* 12-16 *) "%l0"; "%l1"; "%l2"; "%l3"; "%l4";
|
(* 12-16 *) "%l0"; "%l1"; "%l2"; "%l3"; "%l4";
|
||||||
(* 17-18 *) "%g3"; "%g4"
|
(* 17-18 *) "%g3"; "%g4"
|
||||||
|]
|
|]
|
||||||
|
|
||||||
let float_reg_name = [|
|
let float_reg_name = [|
|
||||||
(* 100-105 *) "%f0"; "%f2"; "%f4"; "%f6"; "%f8"; "%f10";
|
(* 100-105 *) "%f0"; "%f2"; "%f4"; "%f6"; "%f8"; "%f10";
|
||||||
(* 106-109 *) "%f12"; "%f14"; "%f16"; "%f18";
|
(* 106-109 *) "%f12"; "%f14"; "%f16"; "%f18";
|
||||||
|
|
|
||||||
|
|
@ -62,4 +62,3 @@ method oper_issue_cycles = function
|
||||||
end
|
end
|
||||||
|
|
||||||
let fundecl f = (new scheduler)#schedule_fundecl f
|
let fundecl f = (new scheduler)#schedule_fundecl f
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -12,7 +12,7 @@
|
||||||
|
|
||||||
(* $Id$ *)
|
(* $Id$ *)
|
||||||
|
|
||||||
(* Insertion of moves to suggest possible spilling / reloading points
|
(* Insertion of moves to suggest possible spilling / reloading points
|
||||||
before register allocation. *)
|
before register allocation. *)
|
||||||
|
|
||||||
open Reg
|
open Reg
|
||||||
|
|
@ -130,7 +130,7 @@ let find_reload_at_exit k =
|
||||||
List.assoc k !reload_at_exit
|
List.assoc k !reload_at_exit
|
||||||
with
|
with
|
||||||
| Not_found -> Misc.fatal_error "Spill.find_reload_at_exit"
|
| Not_found -> Misc.fatal_error "Spill.find_reload_at_exit"
|
||||||
|
|
||||||
let reload_at_break = ref Reg.Set.empty
|
let reload_at_break = ref Reg.Set.empty
|
||||||
|
|
||||||
let rec reload i before =
|
let rec reload i before =
|
||||||
|
|
@ -400,4 +400,3 @@ let fundecl f =
|
||||||
fun_args = f.fun_args;
|
fun_args = f.fun_args;
|
||||||
fun_body = new_body;
|
fun_body = new_body;
|
||||||
fun_fast = f.fun_fast }
|
fun_fast = f.fun_fast }
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -12,7 +12,7 @@
|
||||||
|
|
||||||
(* $Id$ *)
|
(* $Id$ *)
|
||||||
|
|
||||||
(* Insertion of moves to suggest possible spilling / reloading points
|
(* Insertion of moves to suggest possible spilling / reloading points
|
||||||
before register allocation. *)
|
before register allocation. *)
|
||||||
|
|
||||||
val fundecl: Mach.fundecl -> Mach.fundecl
|
val fundecl: Mach.fundecl -> Mach.fundecl
|
||||||
|
|
|
||||||
|
|
@ -189,7 +189,7 @@ let rec rename i sub =
|
||||||
| Iraise ->
|
| Iraise ->
|
||||||
(instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next,
|
(instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next,
|
||||||
None)
|
None)
|
||||||
|
|
||||||
(* Second pass: replace registers by their final representatives *)
|
(* Second pass: replace registers by their final representatives *)
|
||||||
|
|
||||||
let set_repres i =
|
let set_repres i =
|
||||||
|
|
|
||||||
|
|
@ -80,7 +80,7 @@ caml_allocN:
|
||||||
.set at
|
.set at
|
||||||
ret ($26)
|
ret ($26)
|
||||||
.end caml_allocN
|
.end caml_allocN
|
||||||
|
|
||||||
.globl caml_call_gc
|
.globl caml_call_gc
|
||||||
.ent caml_call_gc
|
.ent caml_call_gc
|
||||||
.align 3
|
.align 3
|
||||||
|
|
|
||||||
|
|
@ -52,7 +52,7 @@ FUNCTION(G(caml_call_gc))
|
||||||
movq %rax, G(caml_last_return_address)(%rip)
|
movq %rax, G(caml_last_return_address)(%rip)
|
||||||
leaq 8(%rsp), %rax
|
leaq 8(%rsp), %rax
|
||||||
movq %rax, G(caml_bottom_of_stack)(%rip)
|
movq %rax, G(caml_bottom_of_stack)(%rip)
|
||||||
.L105:
|
.L105:
|
||||||
/* Save caml_young_ptr, caml_exception_pointer */
|
/* Save caml_young_ptr, caml_exception_pointer */
|
||||||
movq %r15, G(caml_young_ptr)(%rip)
|
movq %r15, G(caml_young_ptr)(%rip)
|
||||||
movq %r14, G(caml_exception_pointer)(%rip)
|
movq %r14, G(caml_exception_pointer)(%rip)
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,13 @@
|
||||||
;*********************************************************************
|
;*********************************************************************
|
||||||
;
|
|
||||||
; Objective Caml
|
|
||||||
;
|
;
|
||||||
; Xavier Leroy, projet Gallium, INRIA Rocquencourt
|
; Objective Caml
|
||||||
;
|
;
|
||||||
; Copyright 2006 Institut National de Recherche en Informatique et
|
; Xavier Leroy, projet Gallium, INRIA Rocquencourt
|
||||||
; en Automatique. All rights reserved. This file is distributed
|
;
|
||||||
; under the terms of the GNU Library General Public License, with
|
; Copyright 2006 Institut National de Recherche en Informatique et
|
||||||
; the special exception on linking described in file ../LICENSE.
|
; en Automatique. All rights reserved. This file is distributed
|
||||||
|
; under the terms of the GNU Library General Public License, with
|
||||||
|
; the special exception on linking described in file ../LICENSE.
|
||||||
;
|
;
|
||||||
;*********************************************************************
|
;*********************************************************************
|
||||||
|
|
||||||
|
|
@ -46,11 +46,11 @@ caml_call_gc:
|
||||||
mov caml_last_return_address, rax
|
mov caml_last_return_address, rax
|
||||||
lea rax, [rsp+8]
|
lea rax, [rsp+8]
|
||||||
mov caml_bottom_of_stack, rax
|
mov caml_bottom_of_stack, rax
|
||||||
L105:
|
L105:
|
||||||
; Save caml_young_ptr, caml_exception_pointer
|
; Save caml_young_ptr, caml_exception_pointer
|
||||||
mov caml_young_ptr, r15
|
mov caml_young_ptr, r15
|
||||||
mov caml_exception_pointer, r14
|
mov caml_exception_pointer, r14
|
||||||
; Build array of registers, save it into caml_gc_regs
|
; Build array of registers, save it into caml_gc_regs
|
||||||
push r13
|
push r13
|
||||||
push r12
|
push r12
|
||||||
push rbp
|
push rbp
|
||||||
|
|
@ -65,7 +65,7 @@ L105:
|
||||||
push rbx
|
push rbx
|
||||||
push rax
|
push rax
|
||||||
mov caml_gc_regs, rsp
|
mov caml_gc_regs, rsp
|
||||||
; Save floating-point registers
|
; Save floating-point registers
|
||||||
sub rsp, 16*8
|
sub rsp, 16*8
|
||||||
movlpd QWORD PTR [rsp + 0*8], xmm0
|
movlpd QWORD PTR [rsp + 0*8], xmm0
|
||||||
movlpd QWORD PTR [rsp + 1*8], xmm1
|
movlpd QWORD PTR [rsp + 1*8], xmm1
|
||||||
|
|
@ -83,9 +83,9 @@ L105:
|
||||||
movlpd QWORD PTR [rsp + 13*8], xmm13
|
movlpd QWORD PTR [rsp + 13*8], xmm13
|
||||||
movlpd QWORD PTR [rsp + 14*8], xmm14
|
movlpd QWORD PTR [rsp + 14*8], xmm14
|
||||||
movlpd QWORD PTR [rsp + 15*8], xmm15
|
movlpd QWORD PTR [rsp + 15*8], xmm15
|
||||||
; Call the garbage collector
|
; Call the garbage collector
|
||||||
call caml_garbage_collection
|
call caml_garbage_collection
|
||||||
; Restore all regs used by the code generator
|
; Restore all regs used by the code generator
|
||||||
movlpd xmm0, QWORD PTR [rsp + 0*8]
|
movlpd xmm0, QWORD PTR [rsp + 0*8]
|
||||||
movlpd xmm1, QWORD PTR [rsp + 1*8]
|
movlpd xmm1, QWORD PTR [rsp + 1*8]
|
||||||
movlpd xmm2, QWORD PTR [rsp + 2*8]
|
movlpd xmm2, QWORD PTR [rsp + 2*8]
|
||||||
|
|
@ -116,10 +116,10 @@ L105:
|
||||||
pop rbp
|
pop rbp
|
||||||
pop r12
|
pop r12
|
||||||
pop r13
|
pop r13
|
||||||
; Restore caml_young_ptr, caml_exception_pointer
|
; Restore caml_young_ptr, caml_exception_pointer
|
||||||
mov r15, caml_young_ptr
|
mov r15, caml_young_ptr
|
||||||
mov r14, caml_exception_pointer
|
mov r14, caml_exception_pointer
|
||||||
; Return to caller
|
; Return to caller
|
||||||
ret
|
ret
|
||||||
|
|
||||||
PUBLIC caml_alloc1
|
PUBLIC caml_alloc1
|
||||||
|
|
@ -181,41 +181,41 @@ caml_allocN:
|
||||||
jb L103
|
jb L103
|
||||||
ret
|
ret
|
||||||
L103:
|
L103:
|
||||||
push rax ; save desired size
|
push rax ; save desired size
|
||||||
mov rax, [rsp + 8]
|
mov rax, [rsp + 8]
|
||||||
mov caml_last_return_address, rax
|
mov caml_last_return_address, rax
|
||||||
lea rax, [rsp + 16]
|
lea rax, [rsp + 16]
|
||||||
mov caml_bottom_of_stack, rax
|
mov caml_bottom_of_stack, rax
|
||||||
call L105
|
call L105
|
||||||
pop rax ; recover desired size
|
pop rax ; recover desired size
|
||||||
jmp caml_allocN
|
jmp caml_allocN
|
||||||
|
|
||||||
; Call a C function from Caml
|
; Call a C function from Caml
|
||||||
|
|
||||||
PUBLIC caml_c_call
|
PUBLIC caml_c_call
|
||||||
ALIGN 16
|
ALIGN 16
|
||||||
caml_c_call:
|
caml_c_call:
|
||||||
; Record lowest stack address and return address
|
; Record lowest stack address and return address
|
||||||
pop r12
|
pop r12
|
||||||
mov caml_last_return_address, r12
|
mov caml_last_return_address, r12
|
||||||
mov caml_bottom_of_stack, rsp
|
mov caml_bottom_of_stack, rsp
|
||||||
; Make the exception handler and alloc ptr available to the C code
|
; Make the exception handler and alloc ptr available to the C code
|
||||||
mov caml_young_ptr, r15
|
mov caml_young_ptr, r15
|
||||||
mov caml_exception_pointer, r14
|
mov caml_exception_pointer, r14
|
||||||
; Call the function (address in rax)
|
; Call the function (address in rax)
|
||||||
call rax
|
call rax
|
||||||
; Reload alloc ptr
|
; Reload alloc ptr
|
||||||
mov r15, caml_young_ptr
|
mov r15, caml_young_ptr
|
||||||
; Return to caller
|
; Return to caller
|
||||||
push r12
|
push r12
|
||||||
ret
|
ret
|
||||||
|
|
||||||
; Start the Caml program
|
; Start the Caml program
|
||||||
|
|
||||||
PUBLIC caml_start_program
|
PUBLIC caml_start_program
|
||||||
ALIGN 16
|
ALIGN 16
|
||||||
caml_start_program:
|
caml_start_program:
|
||||||
; Save callee-save registers
|
; Save callee-save registers
|
||||||
push rbx
|
push rbx
|
||||||
push rbp
|
push rbp
|
||||||
push rsi
|
push rsi
|
||||||
|
|
@ -235,39 +235,39 @@ caml_start_program:
|
||||||
movapd OWORD PTR [rsp + 7*16], xmm13
|
movapd OWORD PTR [rsp + 7*16], xmm13
|
||||||
movapd OWORD PTR [rsp + 8*16], xmm14
|
movapd OWORD PTR [rsp + 8*16], xmm14
|
||||||
movapd OWORD PTR [rsp + 9*16], xmm15
|
movapd OWORD PTR [rsp + 9*16], xmm15
|
||||||
; Initial entry point is caml_program
|
; Initial entry point is caml_program
|
||||||
lea r12, caml_program
|
lea r12, caml_program
|
||||||
; Common code for caml_start_program and caml_callback*
|
; Common code for caml_start_program and caml_callback*
|
||||||
L106:
|
L106:
|
||||||
; Build a callback link
|
; Build a callback link
|
||||||
sub rsp, 8 ; stack 16-aligned
|
sub rsp, 8 ; stack 16-aligned
|
||||||
push caml_gc_regs
|
push caml_gc_regs
|
||||||
push caml_last_return_address
|
push caml_last_return_address
|
||||||
push caml_bottom_of_stack
|
push caml_bottom_of_stack
|
||||||
; Setup alloc ptr and exception ptr
|
; Setup alloc ptr and exception ptr
|
||||||
mov r15, caml_young_ptr
|
mov r15, caml_young_ptr
|
||||||
mov r14, caml_exception_pointer
|
mov r14, caml_exception_pointer
|
||||||
; Build an exception handler
|
; Build an exception handler
|
||||||
lea r13, L108
|
lea r13, L108
|
||||||
push r13
|
push r13
|
||||||
push r14
|
push r14
|
||||||
mov r14, rsp
|
mov r14, rsp
|
||||||
; Call the Caml code
|
; Call the Caml code
|
||||||
call r12
|
call r12
|
||||||
L107:
|
L107:
|
||||||
; Pop the exception handler
|
; Pop the exception handler
|
||||||
pop r14
|
pop r14
|
||||||
pop r12 ; dummy register
|
pop r12 ; dummy register
|
||||||
L109:
|
L109:
|
||||||
; Update alloc ptr and exception ptr
|
; Update alloc ptr and exception ptr
|
||||||
mov caml_young_ptr, r15
|
mov caml_young_ptr, r15
|
||||||
mov caml_exception_pointer, r14
|
mov caml_exception_pointer, r14
|
||||||
; Pop the callback restoring, link the global variables
|
; Pop the callback restoring, link the global variables
|
||||||
pop caml_bottom_of_stack
|
pop caml_bottom_of_stack
|
||||||
pop caml_last_return_address
|
pop caml_last_return_address
|
||||||
pop caml_gc_regs
|
pop caml_gc_regs
|
||||||
add rsp, 8
|
add rsp, 8
|
||||||
; Restore callee-save registers.
|
; Restore callee-save registers.
|
||||||
movapd xmm6, OWORD PTR [rsp + 0*16]
|
movapd xmm6, OWORD PTR [rsp + 0*16]
|
||||||
movapd xmm7, OWORD PTR [rsp + 1*16]
|
movapd xmm7, OWORD PTR [rsp + 1*16]
|
||||||
movapd xmm8, OWORD PTR [rsp + 2*16]
|
movapd xmm8, OWORD PTR [rsp + 2*16]
|
||||||
|
|
@ -291,7 +291,7 @@ L109:
|
||||||
ret
|
ret
|
||||||
L108:
|
L108:
|
||||||
; Exception handler
|
; Exception handler
|
||||||
; Mark the bucket as an exception result and return it
|
; Mark the bucket as an exception result and return it
|
||||||
or rax, 2
|
or rax, 2
|
||||||
jmp L109
|
jmp L109
|
||||||
|
|
||||||
|
|
@ -318,7 +318,7 @@ L110:
|
||||||
pop r14 ; Recover previous exception handler
|
pop r14 ; Recover previous exception handler
|
||||||
ret ; Branch to handler
|
ret ; Branch to handler
|
||||||
|
|
||||||
; Raise an exception from C
|
; Raise an exception from C
|
||||||
|
|
||||||
PUBLIC caml_raise_exception
|
PUBLIC caml_raise_exception
|
||||||
ALIGN 16
|
ALIGN 16
|
||||||
|
|
@ -327,8 +327,8 @@ caml_raise_exception:
|
||||||
jne L111
|
jne L111
|
||||||
mov rax, rcx ; First argument is exn bucket
|
mov rax, rcx ; First argument is exn bucket
|
||||||
mov rsp, caml_exception_pointer
|
mov rsp, caml_exception_pointer
|
||||||
pop r14 ; Recover previous exception handler
|
pop r14 ; Recover previous exception handler
|
||||||
mov r15, caml_young_ptr ; Reload alloc ptr
|
mov r15, caml_young_ptr ; Reload alloc ptr
|
||||||
ret
|
ret
|
||||||
L111:
|
L111:
|
||||||
mov r12, rcx ; Save exception bucket in r12
|
mov r12, rcx ; Save exception bucket in r12
|
||||||
|
|
@ -340,16 +340,16 @@ L111:
|
||||||
call caml_stash_backtrace
|
call caml_stash_backtrace
|
||||||
mov rax, r12 ; Recover exception bucket
|
mov rax, r12 ; Recover exception bucket
|
||||||
mov rsp, caml_exception_pointer
|
mov rsp, caml_exception_pointer
|
||||||
pop r14 ; Recover previous exception handler
|
pop r14 ; Recover previous exception handler
|
||||||
mov r15, caml_young_ptr ; Reload alloc ptr
|
mov r15, caml_young_ptr ; Reload alloc ptr
|
||||||
ret
|
ret
|
||||||
|
|
||||||
; Callback from C to Caml
|
; Callback from C to Caml
|
||||||
|
|
||||||
PUBLIC caml_callback_exn
|
PUBLIC caml_callback_exn
|
||||||
ALIGN 16
|
ALIGN 16
|
||||||
caml_callback_exn:
|
caml_callback_exn:
|
||||||
; Save callee-save registers
|
; Save callee-save registers
|
||||||
push rbx
|
push rbx
|
||||||
push rbp
|
push rbp
|
||||||
push rsi
|
push rsi
|
||||||
|
|
@ -369,16 +369,16 @@ caml_callback_exn:
|
||||||
movapd OWORD PTR [rsp + 7*16], xmm13
|
movapd OWORD PTR [rsp + 7*16], xmm13
|
||||||
movapd OWORD PTR [rsp + 8*16], xmm14
|
movapd OWORD PTR [rsp + 8*16], xmm14
|
||||||
movapd OWORD PTR [rsp + 9*16], xmm15
|
movapd OWORD PTR [rsp + 9*16], xmm15
|
||||||
; Initial loading of arguments
|
; Initial loading of arguments
|
||||||
mov rbx, rcx ; closure
|
mov rbx, rcx ; closure
|
||||||
mov rax, rdx ; argument
|
mov rax, rdx ; argument
|
||||||
mov r12, [rbx] ; code pointer
|
mov r12, [rbx] ; code pointer
|
||||||
jmp L106
|
jmp L106
|
||||||
|
|
||||||
PUBLIC caml_callback2_exn
|
PUBLIC caml_callback2_exn
|
||||||
ALIGN 16
|
ALIGN 16
|
||||||
caml_callback2_exn:
|
caml_callback2_exn:
|
||||||
; Save callee-save registers
|
; Save callee-save registers
|
||||||
push rbx
|
push rbx
|
||||||
push rbp
|
push rbp
|
||||||
push rsi
|
push rsi
|
||||||
|
|
@ -398,17 +398,17 @@ caml_callback2_exn:
|
||||||
movapd OWORD PTR [rsp + 7*16], xmm13
|
movapd OWORD PTR [rsp + 7*16], xmm13
|
||||||
movapd OWORD PTR [rsp + 8*16], xmm14
|
movapd OWORD PTR [rsp + 8*16], xmm14
|
||||||
movapd OWORD PTR [rsp + 9*16], xmm15
|
movapd OWORD PTR [rsp + 9*16], xmm15
|
||||||
; Initial loading of arguments
|
; Initial loading of arguments
|
||||||
mov rdi, rcx ; closure
|
mov rdi, rcx ; closure
|
||||||
mov rax, rdx ; first argument
|
mov rax, rdx ; first argument
|
||||||
mov rbx, r8 ; second argument
|
mov rbx, r8 ; second argument
|
||||||
lea r12, caml_apply2 ; code pointer
|
lea r12, caml_apply2 ; code pointer
|
||||||
jmp L106
|
jmp L106
|
||||||
|
|
||||||
PUBLIC caml_callback3_exn
|
PUBLIC caml_callback3_exn
|
||||||
ALIGN 16
|
ALIGN 16
|
||||||
caml_callback3_exn:
|
caml_callback3_exn:
|
||||||
; Save callee-save registers
|
; Save callee-save registers
|
||||||
push rbx
|
push rbx
|
||||||
push rbp
|
push rbp
|
||||||
push rsi
|
push rsi
|
||||||
|
|
@ -428,12 +428,12 @@ caml_callback3_exn:
|
||||||
movapd OWORD PTR [rsp + 7*16], xmm13
|
movapd OWORD PTR [rsp + 7*16], xmm13
|
||||||
movapd OWORD PTR [rsp + 8*16], xmm14
|
movapd OWORD PTR [rsp + 8*16], xmm14
|
||||||
movapd OWORD PTR [rsp + 9*16], xmm15
|
movapd OWORD PTR [rsp + 9*16], xmm15
|
||||||
; Initial loading of arguments
|
; Initial loading of arguments
|
||||||
mov rsi, rcx ; closure
|
mov rsi, rcx ; closure
|
||||||
mov rax, rdx ; first argument
|
mov rax, rdx ; first argument
|
||||||
mov rbx, r8 ; second argument
|
mov rbx, r8 ; second argument
|
||||||
mov rdi, r9 ; third argument
|
mov rdi, r9 ; third argument
|
||||||
lea r12, caml_apply3 ; code pointer
|
lea r12, caml_apply3 ; code pointer
|
||||||
jmp L106
|
jmp L106
|
||||||
|
|
||||||
PUBLIC caml_ml_array_bound_error
|
PUBLIC caml_ml_array_bound_error
|
||||||
|
|
@ -445,10 +445,10 @@ caml_ml_array_bound_error:
|
||||||
.DATA
|
.DATA
|
||||||
PUBLIC caml_system__frametable
|
PUBLIC caml_system__frametable
|
||||||
caml_system__frametable LABEL QWORD
|
caml_system__frametable LABEL QWORD
|
||||||
QWORD 1 ; one descriptor
|
QWORD 1 ; one descriptor
|
||||||
QWORD L107 ; return address into callback
|
QWORD L107 ; return address into callback
|
||||||
WORD -1 ; negative frame size => use callback link
|
WORD -1 ; negative frame size => use callback link
|
||||||
WORD 0 ; no roots here
|
WORD 0 ; no roots here
|
||||||
ALIGN 8
|
ALIGN 8
|
||||||
|
|
||||||
PUBLIC caml_negf_mask
|
PUBLIC caml_negf_mask
|
||||||
|
|
|
||||||
|
|
@ -131,7 +131,7 @@ static void extract_location_info(frame_descr * d,
|
||||||
uint32 info1, info2;
|
uint32 info1, info2;
|
||||||
|
|
||||||
/* If no debugging information available, print nothing.
|
/* If no debugging information available, print nothing.
|
||||||
When everything is compiled with -g, this corresponds to
|
When everything is compiled with -g, this corresponds to
|
||||||
compiler-inserted re-raise operations. */
|
compiler-inserted re-raise operations. */
|
||||||
if ((d->frame_size & 1) == 0) {
|
if ((d->frame_size & 1) == 0) {
|
||||||
li->loc_valid = 0;
|
li->loc_valid = 0;
|
||||||
|
|
@ -147,7 +147,7 @@ static void extract_location_info(frame_descr * d,
|
||||||
info2 = ((uint32 *)infoptr)[1];
|
info2 = ((uint32 *)infoptr)[1];
|
||||||
/* Format of the two info words:
|
/* Format of the two info words:
|
||||||
llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk
|
llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk
|
||||||
44 36 26 2 0
|
44 36 26 2 0
|
||||||
(32+12) (32+4)
|
(32+12) (32+4)
|
||||||
k ( 2 bits): 0 if it's a call, 1 if it's a raise
|
k ( 2 bits): 0 if it's a call, 1 if it's a raise
|
||||||
n (24 bits): offset (in 4-byte words) of file name relative to infoptr
|
n (24 bits): offset (in 4-byte words) of file name relative to infoptr
|
||||||
|
|
@ -222,4 +222,3 @@ CAMLprim value caml_get_exception_backtrace(value unit)
|
||||||
res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
|
res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
|
||||||
CAMLreturn(res);
|
CAMLreturn(res);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -366,7 +366,7 @@ L102:
|
||||||
ldo LOW(G(caml_young_limit))(%r1), %r4
|
ldo LOW(G(caml_young_limit))(%r1), %r4
|
||||||
; Call the Caml code
|
; Call the Caml code
|
||||||
ble 0(4, %r22)
|
ble 0(4, %r22)
|
||||||
copy %r31, %r2
|
copy %r31, %r2
|
||||||
L104:
|
L104:
|
||||||
; Pop the trap frame
|
; Pop the trap frame
|
||||||
ldw -8(%r30), %r31
|
ldw -8(%r30), %r31
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,13 @@
|
||||||
;*********************************************************************
|
;*********************************************************************
|
||||||
;
|
|
||||||
; Objective Caml
|
|
||||||
;
|
;
|
||||||
; Xavier Leroy, projet Cristal, INRIA Rocquencourt
|
; Objective Caml
|
||||||
;
|
;
|
||||||
; Copyright 1996 Institut National de Recherche en Informatique et
|
; Xavier Leroy, projet Cristal, INRIA Rocquencourt
|
||||||
; en Automatique. All rights reserved. This file is distributed
|
;
|
||||||
; under the terms of the GNU Library General Public License, with
|
; Copyright 1996 Institut National de Recherche en Informatique et
|
||||||
; the special exception on linking described in file ../LICENSE.
|
; en Automatique. All rights reserved. This file is distributed
|
||||||
|
; under the terms of the GNU Library General Public License, with
|
||||||
|
; the special exception on linking described in file ../LICENSE.
|
||||||
;
|
;
|
||||||
;*********************************************************************
|
;*********************************************************************
|
||||||
|
|
||||||
|
|
@ -32,7 +32,7 @@
|
||||||
EXTERN _caml_backtrace_active: DWORD
|
EXTERN _caml_backtrace_active: DWORD
|
||||||
EXTERN _caml_stash_backtrace: PROC
|
EXTERN _caml_stash_backtrace: PROC
|
||||||
|
|
||||||
; Allocation
|
; Allocation
|
||||||
|
|
||||||
.CODE
|
.CODE
|
||||||
PUBLIC _caml_alloc1
|
PUBLIC _caml_alloc1
|
||||||
|
|
@ -42,12 +42,12 @@
|
||||||
PUBLIC _caml_call_gc
|
PUBLIC _caml_call_gc
|
||||||
|
|
||||||
_caml_call_gc:
|
_caml_call_gc:
|
||||||
; Record lowest stack address and return address
|
; Record lowest stack address and return address
|
||||||
mov eax, [esp]
|
mov eax, [esp]
|
||||||
mov _caml_last_return_address, eax
|
mov _caml_last_return_address, eax
|
||||||
lea eax, [esp+4]
|
lea eax, [esp+4]
|
||||||
mov _caml_bottom_of_stack, eax
|
mov _caml_bottom_of_stack, eax
|
||||||
; Save all regs used by the code generator
|
; Save all regs used by the code generator
|
||||||
L105: push ebp
|
L105: push ebp
|
||||||
push edi
|
push edi
|
||||||
push esi
|
push esi
|
||||||
|
|
@ -56,9 +56,9 @@ L105: push ebp
|
||||||
push ebx
|
push ebx
|
||||||
push eax
|
push eax
|
||||||
mov _caml_gc_regs, esp
|
mov _caml_gc_regs, esp
|
||||||
; Call the garbage collector
|
; Call the garbage collector
|
||||||
call _caml_garbage_collection
|
call _caml_garbage_collection
|
||||||
; Restore all regs used by the code generator
|
; Restore all regs used by the code generator
|
||||||
pop eax
|
pop eax
|
||||||
pop ebx
|
pop ebx
|
||||||
pop ecx
|
pop ecx
|
||||||
|
|
@ -66,8 +66,8 @@ L105: push ebp
|
||||||
pop esi
|
pop esi
|
||||||
pop edi
|
pop edi
|
||||||
pop ebp
|
pop ebp
|
||||||
; Return to caller
|
; Return to caller
|
||||||
ret
|
ret
|
||||||
|
|
||||||
ALIGN 4
|
ALIGN 4
|
||||||
_caml_alloc1:
|
_caml_alloc1:
|
||||||
|
|
@ -76,7 +76,7 @@ _caml_alloc1:
|
||||||
mov _caml_young_ptr, eax
|
mov _caml_young_ptr, eax
|
||||||
cmp eax, _caml_young_limit
|
cmp eax, _caml_young_limit
|
||||||
jb L100
|
jb L100
|
||||||
ret
|
ret
|
||||||
L100: mov eax, [esp]
|
L100: mov eax, [esp]
|
||||||
mov _caml_last_return_address, eax
|
mov _caml_last_return_address, eax
|
||||||
lea eax, [esp+4]
|
lea eax, [esp+4]
|
||||||
|
|
@ -91,7 +91,7 @@ _caml_alloc2:
|
||||||
mov _caml_young_ptr, eax
|
mov _caml_young_ptr, eax
|
||||||
cmp eax, _caml_young_limit
|
cmp eax, _caml_young_limit
|
||||||
jb L101
|
jb L101
|
||||||
ret
|
ret
|
||||||
L101: mov eax, [esp]
|
L101: mov eax, [esp]
|
||||||
mov _caml_last_return_address, eax
|
mov _caml_last_return_address, eax
|
||||||
lea eax, [esp+4]
|
lea eax, [esp+4]
|
||||||
|
|
@ -106,7 +106,7 @@ _caml_alloc3:
|
||||||
mov _caml_young_ptr, eax
|
mov _caml_young_ptr, eax
|
||||||
cmp eax, _caml_young_limit
|
cmp eax, _caml_young_limit
|
||||||
jb L102
|
jb L102
|
||||||
ret
|
ret
|
||||||
L102: mov eax, [esp]
|
L102: mov eax, [esp]
|
||||||
mov _caml_last_return_address, eax
|
mov _caml_last_return_address, eax
|
||||||
lea eax, [esp+4]
|
lea eax, [esp+4]
|
||||||
|
|
@ -134,25 +134,25 @@ L103: sub eax, _caml_young_ptr ; eax = - size
|
||||||
pop eax ; recover desired size
|
pop eax ; recover desired size
|
||||||
jmp _caml_allocN
|
jmp _caml_allocN
|
||||||
|
|
||||||
; Call a C function from Caml
|
; Call a C function from Caml
|
||||||
|
|
||||||
PUBLIC _caml_c_call
|
PUBLIC _caml_c_call
|
||||||
ALIGN 4
|
ALIGN 4
|
||||||
_caml_c_call:
|
_caml_c_call:
|
||||||
; Record lowest stack address and return address
|
; Record lowest stack address and return address
|
||||||
mov edx, [esp]
|
mov edx, [esp]
|
||||||
mov _caml_last_return_address, edx
|
mov _caml_last_return_address, edx
|
||||||
lea edx, [esp+4]
|
lea edx, [esp+4]
|
||||||
mov _caml_bottom_of_stack, edx
|
mov _caml_bottom_of_stack, edx
|
||||||
; Call the function (address in %eax)
|
; Call the function (address in %eax)
|
||||||
jmp eax
|
jmp eax
|
||||||
|
|
||||||
; Start the Caml program
|
; Start the Caml program
|
||||||
|
|
||||||
PUBLIC _caml_start_program
|
PUBLIC _caml_start_program
|
||||||
ALIGN 4
|
ALIGN 4
|
||||||
_caml_start_program:
|
_caml_start_program:
|
||||||
; Save callee-save registers
|
; Save callee-save registers
|
||||||
push ebx
|
push ebx
|
||||||
push esi
|
push esi
|
||||||
push edi
|
push edi
|
||||||
|
|
@ -163,20 +163,20 @@ _caml_start_program:
|
||||||
; Code shared between caml_start_program and callback*
|
; Code shared between caml_start_program and callback*
|
||||||
|
|
||||||
L106:
|
L106:
|
||||||
; Build a callback link
|
; Build a callback link
|
||||||
push _caml_gc_regs
|
push _caml_gc_regs
|
||||||
push _caml_last_return_address
|
push _caml_last_return_address
|
||||||
push _caml_bottom_of_stack
|
push _caml_bottom_of_stack
|
||||||
; Build an exception handler
|
; Build an exception handler
|
||||||
push L108
|
push L108
|
||||||
push _caml_exception_pointer
|
push _caml_exception_pointer
|
||||||
mov _caml_exception_pointer, esp
|
mov _caml_exception_pointer, esp
|
||||||
; Call the Caml code
|
; Call the Caml code
|
||||||
call esi
|
call esi
|
||||||
L107:
|
L107:
|
||||||
; Pop the exception handler
|
; Pop the exception handler
|
||||||
pop _caml_exception_pointer
|
pop _caml_exception_pointer
|
||||||
pop esi ; dummy register
|
pop esi ; dummy register
|
||||||
L109:
|
L109:
|
||||||
; Pop the callback link, restoring the global variables
|
; Pop the callback link, restoring the global variables
|
||||||
; used by caml_c_call
|
; used by caml_c_call
|
||||||
|
|
@ -188,8 +188,8 @@ L109:
|
||||||
pop edi
|
pop edi
|
||||||
pop esi
|
pop esi
|
||||||
pop ebx
|
pop ebx
|
||||||
; Return to caller.
|
; Return to caller.
|
||||||
ret
|
ret
|
||||||
L108:
|
L108:
|
||||||
; Exception handler
|
; Exception handler
|
||||||
; Mark the bucket as an exception result and return it
|
; Mark the bucket as an exception result and return it
|
||||||
|
|
@ -205,7 +205,7 @@ _caml_raise_exn:
|
||||||
jne L110
|
jne L110
|
||||||
mov esp, _caml_exception_pointer
|
mov esp, _caml_exception_pointer
|
||||||
pop _caml_exception_pointer
|
pop _caml_exception_pointer
|
||||||
ret
|
ret
|
||||||
L110:
|
L110:
|
||||||
mov esi, eax ; Save exception bucket in esi
|
mov esi, eax ; Save exception bucket in esi
|
||||||
mov edi, _caml_exception_pointer ; SP of handler
|
mov edi, _caml_exception_pointer ; SP of handler
|
||||||
|
|
@ -221,7 +221,7 @@ L110:
|
||||||
pop _caml_exception_pointer
|
pop _caml_exception_pointer
|
||||||
ret
|
ret
|
||||||
|
|
||||||
; Raise an exception from C
|
; Raise an exception from C
|
||||||
|
|
||||||
PUBLIC _caml_raise_exception
|
PUBLIC _caml_raise_exception
|
||||||
ALIGN 4
|
ALIGN 4
|
||||||
|
|
@ -231,7 +231,7 @@ _caml_raise_exception:
|
||||||
mov eax, [esp+4]
|
mov eax, [esp+4]
|
||||||
mov esp, _caml_exception_pointer
|
mov esp, _caml_exception_pointer
|
||||||
pop _caml_exception_pointer
|
pop _caml_exception_pointer
|
||||||
ret
|
ret
|
||||||
L111:
|
L111:
|
||||||
mov esi, [esp+4] ; Save exception bucket in esi
|
mov esi, [esp+4] ; Save exception bucket in esi
|
||||||
push _caml_exception_pointer ; arg 4: SP of handler
|
push _caml_exception_pointer ; arg 4: SP of handler
|
||||||
|
|
@ -244,51 +244,51 @@ L111:
|
||||||
pop _caml_exception_pointer
|
pop _caml_exception_pointer
|
||||||
ret
|
ret
|
||||||
|
|
||||||
; Callback from C to Caml
|
; Callback from C to Caml
|
||||||
|
|
||||||
PUBLIC _caml_callback_exn
|
PUBLIC _caml_callback_exn
|
||||||
ALIGN 4
|
ALIGN 4
|
||||||
_caml_callback_exn:
|
_caml_callback_exn:
|
||||||
; Save callee-save registers
|
; Save callee-save registers
|
||||||
push ebx
|
push ebx
|
||||||
push esi
|
push esi
|
||||||
push edi
|
push edi
|
||||||
push ebp
|
push ebp
|
||||||
; Initial loading of arguments
|
; Initial loading of arguments
|
||||||
mov ebx, [esp+20] ; closure
|
mov ebx, [esp+20] ; closure
|
||||||
mov eax, [esp+24] ; argument
|
mov eax, [esp+24] ; argument
|
||||||
mov esi, [ebx] ; code pointer
|
mov esi, [ebx] ; code pointer
|
||||||
jmp L106
|
jmp L106
|
||||||
|
|
||||||
PUBLIC _caml_callback2_exn
|
PUBLIC _caml_callback2_exn
|
||||||
ALIGN 4
|
ALIGN 4
|
||||||
_caml_callback2_exn:
|
_caml_callback2_exn:
|
||||||
; Save callee-save registers
|
; Save callee-save registers
|
||||||
push ebx
|
push ebx
|
||||||
push esi
|
push esi
|
||||||
push edi
|
push edi
|
||||||
push ebp
|
push ebp
|
||||||
; Initial loading of arguments
|
; Initial loading of arguments
|
||||||
mov ecx, [esp+20] ; closure
|
mov ecx, [esp+20] ; closure
|
||||||
mov eax, [esp+24] ; first argument
|
mov eax, [esp+24] ; first argument
|
||||||
mov ebx, [esp+28] ; second argument
|
mov ebx, [esp+28] ; second argument
|
||||||
mov esi, offset _caml_apply2 ; code pointer
|
mov esi, offset _caml_apply2 ; code pointer
|
||||||
jmp L106
|
jmp L106
|
||||||
|
|
||||||
PUBLIC _caml_callback3_exn
|
PUBLIC _caml_callback3_exn
|
||||||
ALIGN 4
|
ALIGN 4
|
||||||
_caml_callback3_exn:
|
_caml_callback3_exn:
|
||||||
; Save callee-save registers
|
; Save callee-save registers
|
||||||
push ebx
|
push ebx
|
||||||
push esi
|
push esi
|
||||||
push edi
|
push edi
|
||||||
push ebp
|
push ebp
|
||||||
; Initial loading of arguments
|
; Initial loading of arguments
|
||||||
mov edx, [esp+20] ; closure
|
mov edx, [esp+20] ; closure
|
||||||
mov eax, [esp+24] ; first argument
|
mov eax, [esp+24] ; first argument
|
||||||
mov ebx, [esp+28] ; second argument
|
mov ebx, [esp+28] ; second argument
|
||||||
mov ecx, [esp+32] ; third argument
|
mov ecx, [esp+32] ; third argument
|
||||||
mov esi, offset _caml_apply3 ; code pointer
|
mov esi, offset _caml_apply3 ; code pointer
|
||||||
jmp L106
|
jmp L106
|
||||||
|
|
||||||
PUBLIC _caml_ml_array_bound_error
|
PUBLIC _caml_ml_array_bound_error
|
||||||
|
|
@ -310,14 +310,13 @@ _caml_ml_array_bound_error:
|
||||||
.DATA
|
.DATA
|
||||||
PUBLIC _caml_system__frametable
|
PUBLIC _caml_system__frametable
|
||||||
_caml_system__frametable LABEL DWORD
|
_caml_system__frametable LABEL DWORD
|
||||||
DWORD 1 ; one descriptor
|
DWORD 1 ; one descriptor
|
||||||
DWORD L107 ; return address into callback
|
DWORD L107 ; return address into callback
|
||||||
WORD -1 ; negative frame size => use callback link
|
WORD -1 ; negative frame size => use callback link
|
||||||
WORD 0 ; no roots here
|
WORD 0 ; no roots here
|
||||||
|
|
||||||
PUBLIC _caml_extra_params
|
PUBLIC _caml_extra_params
|
||||||
_caml_extra_params LABEL DWORD
|
_caml_extra_params LABEL DWORD
|
||||||
BYTE 64 DUP (?)
|
BYTE 64 DUP (?)
|
||||||
|
|
||||||
END
|
END
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -239,7 +239,7 @@ caml_start_program:
|
||||||
mov b6 = r2
|
mov b6 = r2
|
||||||
|
|
||||||
/* Code shared with caml_callback* */
|
/* Code shared with caml_callback* */
|
||||||
.L103:
|
.L103:
|
||||||
/* Allocate 64 "out" registers (for the Caml code) and no locals */
|
/* Allocate 64 "out" registers (for the Caml code) and no locals */
|
||||||
alloc r3 = ar.pfs, 0, 0, 64, 0
|
alloc r3 = ar.pfs, 0, 0, 64, 0
|
||||||
add sp = -(56 * 8), sp ;;
|
add sp = -(56 * 8), sp ;;
|
||||||
|
|
@ -503,7 +503,7 @@ caml_callback3_exn:
|
||||||
.align 16
|
.align 16
|
||||||
caml_ml_array_bound_error:
|
caml_ml_array_bound_error:
|
||||||
ADDRGLOBAL(r2, @fptr(caml_array_bound_error#))
|
ADDRGLOBAL(r2, @fptr(caml_array_bound_error#))
|
||||||
br.sptk caml_c_call /* never returns */
|
br.sptk caml_c_call /* never returns */
|
||||||
|
|
||||||
.rodata
|
.rodata
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -204,7 +204,7 @@ caml_c_call:
|
||||||
Storeglobal(12, caml_last_return_address, 11)
|
Storeglobal(12, caml_last_return_address, 11)
|
||||||
/* Return to caller */
|
/* Return to caller */
|
||||||
blr
|
blr
|
||||||
|
|
||||||
/* Raise an exception from C */
|
/* Raise an exception from C */
|
||||||
|
|
||||||
.globl caml_raise_exception
|
.globl caml_raise_exception
|
||||||
|
|
@ -298,7 +298,7 @@ caml_start_program:
|
||||||
stw 11, 4(1)
|
stw 11, 4(1)
|
||||||
mr 29, 1
|
mr 29, 1
|
||||||
/* Reload allocation pointers */
|
/* Reload allocation pointers */
|
||||||
Loadglobal(31, caml_young_ptr, 11)
|
Loadglobal(31, caml_young_ptr, 11)
|
||||||
Loadglobal(30, caml_young_limit, 11)
|
Loadglobal(30, caml_young_limit, 11)
|
||||||
/* Say we are back into Caml code */
|
/* Say we are back into Caml code */
|
||||||
li 0, 0
|
li 0, 0
|
||||||
|
|
@ -316,9 +316,9 @@ caml_start_program:
|
||||||
lwz 9, 0(1)
|
lwz 9, 0(1)
|
||||||
lwz 10, 4(1)
|
lwz 10, 4(1)
|
||||||
lwz 11, 8(1)
|
lwz 11, 8(1)
|
||||||
Storeglobal(9, caml_bottom_of_stack, 12)
|
Storeglobal(9, caml_bottom_of_stack, 12)
|
||||||
Storeglobal(10, caml_last_return_address, 12)
|
Storeglobal(10, caml_last_return_address, 12)
|
||||||
Storeglobal(11, caml_gc_regs, 12)
|
Storeglobal(11, caml_gc_regs, 12)
|
||||||
addi 1, 1, 16
|
addi 1, 1, 16
|
||||||
/* Update allocation pointer */
|
/* Update allocation pointer */
|
||||||
Storeglobal(31, caml_young_ptr, 11)
|
Storeglobal(31, caml_young_ptr, 11)
|
||||||
|
|
@ -396,7 +396,7 @@ caml_callback2_exn:
|
||||||
mr 5, 0
|
mr 5, 0
|
||||||
Addrglobal(12, caml_apply2)
|
Addrglobal(12, caml_apply2)
|
||||||
b .L102
|
b .L102
|
||||||
|
|
||||||
.globl caml_callback3_exn
|
.globl caml_callback3_exn
|
||||||
.type caml_callback3_exn, @function
|
.type caml_callback3_exn, @function
|
||||||
caml_callback3_exn:
|
caml_callback3_exn:
|
||||||
|
|
@ -418,4 +418,3 @@ caml_system__frametable:
|
||||||
.long .L105 + 4 /* return address into callback */
|
.long .L105 + 4 /* return address into callback */
|
||||||
.short -1 /* negative size count => use callback link */
|
.short -1 /* negative size count => use callback link */
|
||||||
.short 0 /* no roots here */
|
.short 0 /* no roots here */
|
||||||
|
|
||||||
|
|
|
||||||
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamldep
BIN
boot/ocamldep
Binary file not shown.
|
|
@ -26,7 +26,7 @@ bad() {
|
||||||
}
|
}
|
||||||
|
|
||||||
finish_if_bad() {
|
finish_if_bad() {
|
||||||
if [ -f buildbot.failed ]; then
|
if [ -f buildbot.failed ]; then
|
||||||
finish
|
finish
|
||||||
exit 2
|
exit 2
|
||||||
fi
|
fi
|
||||||
|
|
|
||||||
|
|
@ -8,5 +8,3 @@ sed -e 's/^\(.*\$([0-9]).*\)$/# \1/' \
|
||||||
-e 's/^FLEX.*$//g' \
|
-e 's/^FLEX.*$//g' \
|
||||||
-e 's/^\([^#=]*\)=\([^"]*\)$/if [ "x$\1" = "x" ]; then \1="\2"; fi/' \
|
-e 's/^\([^#=]*\)=\([^"]*\)$/if [ "x$\1" = "x" ]; then \1="\2"; fi/' \
|
||||||
config/Makefile > config/config.sh
|
config/Makefile > config/config.sh
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ if [ ! -x _build/ocamlbuild/ocamlbuildlight.byte ]; then
|
||||||
(cd ocamlbuild && make)
|
(cd ocamlbuild && make)
|
||||||
fi
|
fi
|
||||||
mkdir -p _build/ocamlbuild
|
mkdir -p _build/ocamlbuild
|
||||||
for i in "light.cmo" "light.byte" "lightlib.cma" "_plugin.cmi" "_pack.cmi"
|
for i in "light.cmo" "light.byte" "lightlib.cma" "_plugin.cmi" "_pack.cmi"
|
||||||
do
|
do
|
||||||
cp ocamlbuild/_build/ocamlbuild$i _build/ocamlbuild
|
cp ocamlbuild/_build/ocamlbuild$i _build/ocamlbuild
|
||||||
done
|
done
|
||||||
fi
|
fi
|
||||||
rm -f ocamlbuild/myocamlbuild_config.ml ocamlbuild/myocamlbuild_config.mli
|
rm -f ocamlbuild/myocamlbuild_config.ml ocamlbuild/myocamlbuild_config.mli
|
||||||
|
|
|
||||||
|
|
@ -37,7 +37,7 @@ let copy_compunit ic oc compunit =
|
||||||
end
|
end
|
||||||
|
|
||||||
(* Add C objects and options and "custom" info from a library descriptor *)
|
(* Add C objects and options and "custom" info from a library descriptor *)
|
||||||
|
|
||||||
let lib_sharedobjs = ref []
|
let lib_sharedobjs = ref []
|
||||||
let lib_ccobjs = ref []
|
let lib_ccobjs = ref []
|
||||||
let lib_ccopts = ref []
|
let lib_ccopts = ref []
|
||||||
|
|
@ -119,4 +119,3 @@ let report_error ppf = function
|
||||||
fprintf ppf "Cannot find file %s" name
|
fprintf ppf "Cannot find file %s" name
|
||||||
| Not_an_object_file name ->
|
| Not_an_object_file name ->
|
||||||
fprintf ppf "The file %s is not a bytecode object file" name
|
fprintf ppf "The file %s is not a bytecode object file" name
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -58,4 +58,3 @@ type library =
|
||||||
...
|
...
|
||||||
object code for last library member
|
object code for last library member
|
||||||
library descriptor *)
|
library descriptor *)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -172,4 +172,3 @@ let init_toplevel dllpath =
|
||||||
opened_dlls := Array.to_list (get_current_dlls());
|
opened_dlls := Array.to_list (get_current_dlls());
|
||||||
names_of_opened_dlls := [];
|
names_of_opened_dlls := [];
|
||||||
linking_in_core := true
|
linking_in_core := true
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -58,4 +58,3 @@ val init_compile: bool -> unit
|
||||||
contents of ld.conf file). Take note of the DLLs that were opened
|
contents of ld.conf file). Take note of the DLLs that were opened
|
||||||
when starting the running program. *)
|
when starting the running program. *)
|
||||||
val init_toplevel: string -> unit
|
val init_toplevel: string -> unit
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -69,7 +69,7 @@ let out_const c =
|
||||||
out_int (const_as_int c)
|
out_int (const_as_int c)
|
||||||
with
|
with
|
||||||
| AsInt -> Misc.fatal_error "Emitcode.const_as_int"
|
| AsInt -> Misc.fatal_error "Emitcode.const_as_int"
|
||||||
|
|
||||||
|
|
||||||
(* Handling of local labels and backpatching *)
|
(* Handling of local labels and backpatching *)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -423,5 +423,3 @@ and negate_comparison = function
|
||||||
| Ceq -> Cneq| Cneq -> Ceq
|
| Ceq -> Cneq| Cneq -> Ceq
|
||||||
| Clt -> Cge | Cle -> Cgt
|
| Clt -> Cge | Cle -> Cgt
|
||||||
| Cgt -> Cle | Cge -> Clt
|
| Cgt -> Cle | Cge -> Clt
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -205,4 +205,3 @@ val staticfail : lambda (* Anticipated static failure *)
|
||||||
(* Check anticipated failure, substitute its final value *)
|
(* Check anticipated failure, substitute its final value *)
|
||||||
val is_guarded: lambda -> bool
|
val is_guarded: lambda -> bool
|
||||||
val patch_guarded : lambda -> lambda -> lambda
|
val patch_guarded : lambda -> lambda -> lambda
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -59,7 +59,7 @@ let pretty_ctx ctx =
|
||||||
let le_ctx c1 c2 =
|
let le_ctx c1 c2 =
|
||||||
le_pats c1.left c2.left &&
|
le_pats c1.left c2.left &&
|
||||||
le_pats c1.right c2.right
|
le_pats c1.right c2.right
|
||||||
|
|
||||||
let lshift {left=left ; right=right} = match right with
|
let lshift {left=left ; right=right} = match right with
|
||||||
| x::xs -> {left=x::left ; right=xs}
|
| x::xs -> {left=x::left ; right=xs}
|
||||||
| _ -> assert false
|
| _ -> assert false
|
||||||
|
|
@ -77,7 +77,7 @@ let rec small_enough n = function
|
||||||
let ctx_lshift ctx =
|
let ctx_lshift ctx =
|
||||||
if small_enough 31 ctx then
|
if small_enough 31 ctx then
|
||||||
List.map lshift ctx
|
List.map lshift ctx
|
||||||
else (* Context pruning *) begin
|
else (* Context pruning *) begin
|
||||||
get_mins le_ctx (List.map lforget ctx)
|
get_mins le_ctx (List.map lforget ctx)
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
@ -94,7 +94,7 @@ let rec nchars n ps =
|
||||||
let chars, cdrs = nchars (n-1) rem in
|
let chars, cdrs = nchars (n-1) rem in
|
||||||
p::chars,cdrs
|
p::chars,cdrs
|
||||||
| _ -> assert false
|
| _ -> assert false
|
||||||
|
|
||||||
let rshift_num n {left=left ; right=right} =
|
let rshift_num n {left=left ; right=right} =
|
||||||
let shifted,left = nchars n left in
|
let shifted,left = nchars n left in
|
||||||
{left=left ; right = shifted@right}
|
{left=left ; right = shifted@right}
|
||||||
|
|
@ -298,7 +298,7 @@ let rec jumps_extract i = function
|
||||||
let rec jumps_remove i = function
|
let rec jumps_remove i = function
|
||||||
| [] -> []
|
| [] -> []
|
||||||
| (j,_)::rem when i=j -> rem
|
| (j,_)::rem when i=j -> rem
|
||||||
| x::rem -> x::jumps_remove i rem
|
| x::rem -> x::jumps_remove i rem
|
||||||
|
|
||||||
let jumps_empty = []
|
let jumps_empty = []
|
||||||
and jumps_is_empty = function
|
and jumps_is_empty = function
|
||||||
|
|
@ -363,7 +363,7 @@ type pm_or_compiled =
|
||||||
or_matrix : matrix ; }
|
or_matrix : matrix ; }
|
||||||
|
|
||||||
type pm_half_compiled =
|
type pm_half_compiled =
|
||||||
| PmOr of pm_or_compiled
|
| PmOr of pm_or_compiled
|
||||||
| PmVar of pm_var_compiled
|
| PmVar of pm_var_compiled
|
||||||
| Pm of pattern_matching
|
| Pm of pattern_matching
|
||||||
|
|
||||||
|
|
@ -507,7 +507,7 @@ exception Var of pattern
|
||||||
let simplify_or p =
|
let simplify_or p =
|
||||||
let rec simpl_rec p = match p with
|
let rec simpl_rec p = match p with
|
||||||
| {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p)
|
| {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p)
|
||||||
| {pat_desc = Tpat_alias (q,id)} ->
|
| {pat_desc = Tpat_alias (q,id)} ->
|
||||||
begin try
|
begin try
|
||||||
{p with pat_desc = Tpat_alias (simpl_rec q,id)}
|
{p with pat_desc = Tpat_alias (simpl_rec q,id)}
|
||||||
with
|
with
|
||||||
|
|
@ -515,15 +515,15 @@ let simplify_or p =
|
||||||
end
|
end
|
||||||
| {pat_desc = Tpat_or (p1,p2,o)} ->
|
| {pat_desc = Tpat_or (p1,p2,o)} ->
|
||||||
let q1 = simpl_rec p1 in
|
let q1 = simpl_rec p1 in
|
||||||
begin try
|
begin try
|
||||||
let q2 = simpl_rec p2 in
|
let q2 = simpl_rec p2 in
|
||||||
{p with pat_desc = Tpat_or (q1, q2, o)}
|
{p with pat_desc = Tpat_or (q1, q2, o)}
|
||||||
with
|
with
|
||||||
| Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)})
|
| Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)})
|
||||||
end
|
end
|
||||||
| {pat_desc = Tpat_record lbls} ->
|
| {pat_desc = Tpat_record lbls} ->
|
||||||
let all_lbls = all_record_args lbls in
|
let all_lbls = all_record_args lbls in
|
||||||
{p with pat_desc=Tpat_record all_lbls}
|
{p with pat_desc=Tpat_record all_lbls}
|
||||||
| _ -> p in
|
| _ -> p in
|
||||||
try
|
try
|
||||||
simpl_rec p
|
simpl_rec p
|
||||||
|
|
@ -577,7 +577,7 @@ let rec what_is_cases cases = match cases with
|
||||||
| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_))}::_),_)::_
|
| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_))}::_),_)::_
|
||||||
-> assert false (* applies to simplified matchings only *)
|
-> assert false (* applies to simplified matchings only *)
|
||||||
| (p::_,_)::_ -> p
|
| (p::_,_)::_ -> p
|
||||||
| [] -> omega
|
| [] -> omega
|
||||||
| _ -> assert false
|
| _ -> assert false
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -633,7 +633,7 @@ let mk_alpha_env arg aliases ids =
|
||||||
match arg with
|
match arg with
|
||||||
| Some v -> v
|
| Some v -> v
|
||||||
| _ -> raise Cannot_flatten
|
| _ -> raise Cannot_flatten
|
||||||
else
|
else
|
||||||
Ident.create (Ident.name id))
|
Ident.create (Ident.name id))
|
||||||
ids
|
ids
|
||||||
|
|
||||||
|
|
@ -646,10 +646,10 @@ let rec explode_or_pat arg patl mk_action rem vars aliases = function
|
||||||
| {pat_desc = Tpat_alias (p,id)} ->
|
| {pat_desc = Tpat_alias (p,id)} ->
|
||||||
explode_or_pat arg patl mk_action rem vars (id::aliases) p
|
explode_or_pat arg patl mk_action rem vars (id::aliases) p
|
||||||
| {pat_desc = Tpat_var x} ->
|
| {pat_desc = Tpat_var x} ->
|
||||||
let env = mk_alpha_env arg (x::aliases) vars in
|
let env = mk_alpha_env arg (x::aliases) vars in
|
||||||
(omega::patl,mk_action (List.map snd env))::rem
|
(omega::patl,mk_action (List.map snd env))::rem
|
||||||
| p ->
|
| p ->
|
||||||
let env = mk_alpha_env arg aliases vars in
|
let env = mk_alpha_env arg aliases vars in
|
||||||
(alpha_pat env p::patl,mk_action (List.map snd env))::rem
|
(alpha_pat env p::patl,mk_action (List.map snd env))::rem
|
||||||
|
|
||||||
let pm_free_variables {cases=cases} =
|
let pm_free_variables {cases=cases} =
|
||||||
|
|
@ -758,7 +758,7 @@ let insert_or_append p ps act ors no =
|
||||||
else (* fail to insert or append *)
|
else (* fail to insert or append *)
|
||||||
ors,(p::ps,act)::no
|
ors,(p::ps,act)::no
|
||||||
else if condb act_q ps qs then (* check condition (b) for append *)
|
else if condb act_q ps qs then (* check condition (b) for append *)
|
||||||
attempt (cl::seen) rem
|
attempt (cl::seen) rem
|
||||||
else
|
else
|
||||||
ors,(p::ps,act)::no
|
ors,(p::ps,act)::no
|
||||||
else (* p # q, go on with append/insert *)
|
else (* p # q, go on with append/insert *)
|
||||||
|
|
@ -781,7 +781,7 @@ let rec rebuild_default nexts def = match nexts with
|
||||||
| (e, pmh)::rem ->
|
| (e, pmh)::rem ->
|
||||||
(add_omega_column (rebuild_matrix pmh), e)::
|
(add_omega_column (rebuild_matrix pmh), e)::
|
||||||
rebuild_default rem def
|
rebuild_default rem def
|
||||||
|
|
||||||
let rebuild_nexts arg nexts k =
|
let rebuild_nexts arg nexts k =
|
||||||
List.fold_right
|
List.fold_right
|
||||||
(fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k)
|
(fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k)
|
||||||
|
|
@ -840,7 +840,7 @@ let rec split_or argo cls args def =
|
||||||
| rem ->
|
| rem ->
|
||||||
let {me=next ; matrix=matrix ; top_default=def},nexts =
|
let {me=next ; matrix=matrix ; top_default=def},nexts =
|
||||||
do_split [] [] [] rem in
|
do_split [] [] [] rem in
|
||||||
let idef = next_raise_count () in
|
let idef = next_raise_count () in
|
||||||
precompile_or
|
precompile_or
|
||||||
argo yes yesor args
|
argo yes yesor args
|
||||||
(cons_default matrix idef def)
|
(cons_default matrix idef def)
|
||||||
|
|
@ -869,10 +869,10 @@ and split_constr cls args def k =
|
||||||
begin match yes with
|
begin match yes with
|
||||||
| [] ->
|
| [] ->
|
||||||
(* Could not success in raising up a constr matching up *)
|
(* Could not success in raising up a constr matching up *)
|
||||||
split_noex [cl] [] rem
|
split_noex [cl] [] rem
|
||||||
| _ ->
|
| _ ->
|
||||||
let {me=next ; matrix=matrix ; top_default=def}, nexts =
|
let {me=next ; matrix=matrix ; top_default=def}, nexts =
|
||||||
split_noex [cl] [] rem in
|
split_noex [cl] [] rem in
|
||||||
let idef = next_raise_count () in
|
let idef = next_raise_count () in
|
||||||
let def = cons_default matrix idef def in
|
let def = cons_default matrix idef def in
|
||||||
{me = Pm {cases=yes ; args=args ; default=def} ;
|
{me = Pm {cases=yes ; args=args ; default=def} ;
|
||||||
|
|
@ -936,7 +936,7 @@ and precompile_var args cls def k = match args with
|
||||||
and var_def = make_default (fun _ rem -> rem) def in
|
and var_def = make_default (fun _ rem -> rem) def in
|
||||||
let {me=first ; matrix=matrix}, nexts =
|
let {me=first ; matrix=matrix}, nexts =
|
||||||
split_or (Some v) var_cls (arg::rargs) var_def in
|
split_or (Some v) var_cls (arg::rargs) var_def in
|
||||||
|
|
||||||
(* Compute top information *)
|
(* Compute top information *)
|
||||||
match nexts with
|
match nexts with
|
||||||
| [] -> (* If you need *)
|
| [] -> (* If you need *)
|
||||||
|
|
@ -962,7 +962,7 @@ and precompile_or argo cls ors args def k = match ors with
|
||||||
| _ ->
|
| _ ->
|
||||||
let rec do_cases = function
|
let rec do_cases = function
|
||||||
| ({pat_desc=Tpat_or _} as orp::patl, action)::rem ->
|
| ({pat_desc=Tpat_or _} as orp::patl, action)::rem ->
|
||||||
let others,rem = get_equiv orp rem in
|
let others,rem = get_equiv orp rem in
|
||||||
let orpm =
|
let orpm =
|
||||||
{cases =
|
{cases =
|
||||||
(patl, action)::
|
(patl, action)::
|
||||||
|
|
@ -1033,7 +1033,7 @@ let add make_matching_fun division key patl_action args =
|
||||||
cell.pm.cases <- [patl_action] ;
|
cell.pm.cases <- [patl_action] ;
|
||||||
(key, cell) :: division
|
(key, cell) :: division
|
||||||
|
|
||||||
|
|
||||||
let divide make get_key get_args ctx pm =
|
let divide make get_key get_args ctx pm =
|
||||||
|
|
||||||
let rec divide_rec = function
|
let rec divide_rec = function
|
||||||
|
|
@ -1068,7 +1068,7 @@ let divide_line make_ctx make get_args pat ctx pm =
|
||||||
They may raise NoMatch or OrPat and perform the full
|
They may raise NoMatch or OrPat and perform the full
|
||||||
matching (selection + arguments).
|
matching (selection + arguments).
|
||||||
|
|
||||||
|
|
||||||
- get_args and get_key are for the compiled matrices, note that
|
- get_args and get_key are for the compiled matrices, note that
|
||||||
selection and geting arguments are separed.
|
selection and geting arguments are separed.
|
||||||
|
|
||||||
|
|
@ -1103,7 +1103,7 @@ let make_constant_matching p def ctx = function
|
||||||
let def =
|
let def =
|
||||||
make_default
|
make_default
|
||||||
(matcher_const (get_key_constant "make" p)) def
|
(matcher_const (get_key_constant "make" p)) def
|
||||||
and ctx =
|
and ctx =
|
||||||
filter_ctx p ctx in
|
filter_ctx p ctx in
|
||||||
{pm = {cases = []; args = argl ; default = def} ;
|
{pm = {cases = []; args = argl ; default = def} ;
|
||||||
ctx = ctx ;
|
ctx = ctx ;
|
||||||
|
|
@ -1222,7 +1222,7 @@ let rec matcher_variant_const lab p rem = match p.pat_desc with
|
||||||
| Tpat_any -> rem
|
| Tpat_any -> rem
|
||||||
| _ -> raise NoMatch
|
| _ -> raise NoMatch
|
||||||
|
|
||||||
|
|
||||||
let make_variant_matching_constant p lab def ctx = function
|
let make_variant_matching_constant p lab def ctx = function
|
||||||
[] -> fatal_error "Matching.make_variant_matching_constant"
|
[] -> fatal_error "Matching.make_variant_matching_constant"
|
||||||
| ((arg, mut) :: argl) ->
|
| ((arg, mut) :: argl) ->
|
||||||
|
|
@ -1269,7 +1269,7 @@ let divide_variant row ctx {cases = cl; args = al; default=def} =
|
||||||
match pato with
|
match pato with
|
||||||
None ->
|
None ->
|
||||||
add (make_variant_matching_constant p lab def ctx) variants
|
add (make_variant_matching_constant p lab def ctx) variants
|
||||||
(Cstr_constant tag) (patl, action) al
|
(Cstr_constant tag) (patl, action) al
|
||||||
| Some pat ->
|
| Some pat ->
|
||||||
add (make_variant_matching_nonconst p lab def ctx) variants
|
add (make_variant_matching_nonconst p lab def ctx) variants
|
||||||
(Cstr_block tag) (pat :: patl, action) al
|
(Cstr_block tag) (pat :: patl, action) al
|
||||||
|
|
@ -1378,7 +1378,7 @@ let inline_lazy_force_switch arg loc =
|
||||||
Lprim(Pisint, [varg]), varg,
|
Lprim(Pisint, [varg]), varg,
|
||||||
(Lswitch
|
(Lswitch
|
||||||
(varg,
|
(varg,
|
||||||
{ sw_numconsts = 0; sw_consts = [];
|
{ sw_numconsts = 0; sw_consts = [];
|
||||||
sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1;
|
sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1;
|
||||||
sw_blocks =
|
sw_blocks =
|
||||||
[ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
|
[ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
|
||||||
|
|
@ -1423,7 +1423,7 @@ let matcher_tuple arity p rem = match p.pat_desc with
|
||||||
| Tpat_or (_,_,_) -> raise OrPat
|
| Tpat_or (_,_,_) -> raise OrPat
|
||||||
| Tpat_var _ -> get_args_tuple arity omega rem
|
| Tpat_var _ -> get_args_tuple arity omega rem
|
||||||
| _ -> get_args_tuple arity p rem
|
| _ -> get_args_tuple arity p rem
|
||||||
|
|
||||||
let make_tuple_matching arity def = function
|
let make_tuple_matching arity def = function
|
||||||
[] -> fatal_error "Matching.make_tuple_matching"
|
[] -> fatal_error "Matching.make_tuple_matching"
|
||||||
| (arg, mut) :: argl ->
|
| (arg, mut) :: argl ->
|
||||||
|
|
@ -1525,7 +1525,7 @@ let divide_array kind ctx pm =
|
||||||
divide
|
divide
|
||||||
(make_array_matching kind)
|
(make_array_matching kind)
|
||||||
get_key_array get_args_array ctx pm
|
get_key_array get_args_array ctx pm
|
||||||
|
|
||||||
(* To combine sub-matchings together *)
|
(* To combine sub-matchings together *)
|
||||||
|
|
||||||
let float_compare s1 s2 =
|
let float_compare s1 s2 =
|
||||||
|
|
@ -1641,16 +1641,16 @@ let make_switch_switcher arg cases acts =
|
||||||
let l = ref [] in
|
let l = ref [] in
|
||||||
for i = Array.length cases-1 downto 0 do
|
for i = Array.length cases-1 downto 0 do
|
||||||
l := (i,acts.(cases.(i))) :: !l
|
l := (i,acts.(cases.(i))) :: !l
|
||||||
done ;
|
done ;
|
||||||
Lswitch(arg,
|
Lswitch(arg,
|
||||||
{sw_numconsts = Array.length cases ; sw_consts = !l ;
|
{sw_numconsts = Array.length cases ; sw_consts = !l ;
|
||||||
sw_numblocks = 0 ; sw_blocks = [] ;
|
sw_numblocks = 0 ; sw_blocks = [] ;
|
||||||
sw_failaction = None})
|
sw_failaction = None})
|
||||||
|
|
||||||
let full sw =
|
let full sw =
|
||||||
List.length sw.sw_consts = sw.sw_numconsts &&
|
List.length sw.sw_consts = sw.sw_numconsts &&
|
||||||
List.length sw.sw_blocks = sw.sw_numblocks
|
List.length sw.sw_blocks = sw.sw_numblocks
|
||||||
|
|
||||||
let make_switch (arg,sw) = match sw.sw_failaction with
|
let make_switch (arg,sw) = match sw.sw_failaction with
|
||||||
| None ->
|
| None ->
|
||||||
let t = Hashtbl.create 17 in
|
let t = Hashtbl.create 17 in
|
||||||
|
|
@ -1685,7 +1685,7 @@ sw_failaction = Some (Lstaticraise (default,[]))})
|
||||||
else
|
else
|
||||||
Lswitch (arg,sw)
|
Lswitch (arg,sw)
|
||||||
| _ -> Lswitch (arg,sw)
|
| _ -> Lswitch (arg,sw)
|
||||||
|
|
||||||
module SArg = struct
|
module SArg = struct
|
||||||
type primitive = Lambda.primitive
|
type primitive = Lambda.primitive
|
||||||
|
|
||||||
|
|
@ -1730,7 +1730,7 @@ let get_edges low high l = match l with
|
||||||
| [] -> low, high
|
| [] -> low, high
|
||||||
| (x,_)::_ -> x, last high l
|
| (x,_)::_ -> x, last high l
|
||||||
|
|
||||||
|
|
||||||
let as_interval_canfail fail low high l =
|
let as_interval_canfail fail low high l =
|
||||||
let store = mk_store equal_action in
|
let store = mk_store equal_action in
|
||||||
let rec nofail_rec cur_low cur_high cur_act = function
|
let rec nofail_rec cur_low cur_high cur_act = function
|
||||||
|
|
@ -1897,12 +1897,12 @@ let mk_res get_key env last_choice idef cant_fail ctx =
|
||||||
let klist =
|
let klist =
|
||||||
List.fold_right
|
List.fold_right
|
||||||
(fun pat klist -> (get_key pat,act)::klist)
|
(fun pat klist -> (get_key pat,act)::klist)
|
||||||
pats klist
|
pats klist
|
||||||
and ctx = if cant_fail then ctx else ctx_lub pat ctx in
|
and ctx = if cant_fail then ctx else ctx_lub pat ctx in
|
||||||
klist,jumps_add i ctx jumps)
|
klist,jumps_add i ctx jumps)
|
||||||
env ([],jumps_fail) in
|
env ([],jumps_fail) in
|
||||||
fail, klist, jumps
|
fail, klist, jumps
|
||||||
|
|
||||||
|
|
||||||
(*
|
(*
|
||||||
Following two ``failaction'' function compute n, the trap handler
|
Following two ``failaction'' function compute n, the trap handler
|
||||||
|
|
@ -1923,8 +1923,8 @@ let mk_failaction_neg partial ctx def = match partial with
|
||||||
| Total ->
|
| Total ->
|
||||||
None, [], jumps_empty
|
None, [], jumps_empty
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(* Conforme a l'article et plus simple qu'avant *)
|
(* Conforme a l'article et plus simple qu'avant *)
|
||||||
and mk_failaction_pos partial seen ctx defs =
|
and mk_failaction_pos partial seen ctx defs =
|
||||||
let rec scan_def env to_test defs = match to_test,defs with
|
let rec scan_def env to_test defs = match to_test,defs with
|
||||||
|
|
@ -1955,8 +1955,8 @@ and mk_failaction_pos partial seen ctx defs =
|
||||||
(complete_pats_constrs seen))
|
(complete_pats_constrs seen))
|
||||||
defs
|
defs
|
||||||
|
|
||||||
|
|
||||||
let combine_constant arg cst partial ctx def
|
let combine_constant arg cst partial ctx def
|
||||||
(const_lambda_list, total, pats) =
|
(const_lambda_list, total, pats) =
|
||||||
let fail, to_add, local_jumps =
|
let fail, to_add, local_jumps =
|
||||||
mk_failaction_neg partial ctx def in
|
mk_failaction_neg partial ctx def in
|
||||||
|
|
@ -2016,12 +2016,12 @@ let split_cases tag_lambda_list =
|
||||||
let const, nonconst = split_rec tag_lambda_list in
|
let const, nonconst = split_rec tag_lambda_list in
|
||||||
sort_int_lambda_list const,
|
sort_int_lambda_list const,
|
||||||
sort_int_lambda_list nonconst
|
sort_int_lambda_list nonconst
|
||||||
|
|
||||||
|
|
||||||
let combine_constructor arg ex_pat cstr partial ctx def
|
let combine_constructor arg ex_pat cstr partial ctx def
|
||||||
(tag_lambda_list, total1, pats) =
|
(tag_lambda_list, total1, pats) =
|
||||||
if cstr.cstr_consts < 0 then begin
|
if cstr.cstr_consts < 0 then begin
|
||||||
(* Special cases for exceptions *)
|
(* Special cases for exceptions *)
|
||||||
let fail, to_add, local_jumps =
|
let fail, to_add, local_jumps =
|
||||||
mk_failaction_neg partial ctx def in
|
mk_failaction_neg partial ctx def in
|
||||||
let tag_lambda_list = to_add@tag_lambda_list in
|
let tag_lambda_list = to_add@tag_lambda_list in
|
||||||
|
|
@ -2159,7 +2159,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
|
||||||
in
|
in
|
||||||
lambda1, jumps_union local_jumps total1
|
lambda1, jumps_union local_jumps total1
|
||||||
|
|
||||||
|
|
||||||
let combine_array arg kind partial ctx def
|
let combine_array arg kind partial ctx def
|
||||||
(len_lambda_list, total1, pats) =
|
(len_lambda_list, total1, pats) =
|
||||||
let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in
|
let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in
|
||||||
|
|
@ -2208,12 +2208,12 @@ let rec event_branch repr lam =
|
||||||
comp_match_handlers (for compililing splitted matches)
|
comp_match_handlers (for compililing splitted matches)
|
||||||
may reraise Unused
|
may reraise Unused
|
||||||
|
|
||||||
|
|
||||||
*)
|
*)
|
||||||
|
|
||||||
exception Unused
|
exception Unused
|
||||||
|
|
||||||
let compile_list compile_fun division =
|
let compile_list compile_fun division =
|
||||||
|
|
||||||
let rec c_rec totals = function
|
let rec c_rec totals = function
|
||||||
| [] -> [], jumps_unions totals, []
|
| [] -> [], jumps_unions totals, []
|
||||||
|
|
@ -2222,7 +2222,7 @@ let compile_list compile_fun division =
|
||||||
| [] -> c_rec totals rem
|
| [] -> c_rec totals rem
|
||||||
| _ ->
|
| _ ->
|
||||||
try
|
try
|
||||||
let (lambda1, total1) = compile_fun cell.ctx cell.pm in
|
let (lambda1, total1) = compile_fun cell.ctx cell.pm in
|
||||||
let c_rem, total, new_pats =
|
let c_rem, total, new_pats =
|
||||||
c_rec
|
c_rec
|
||||||
(jumps_map ctx_combine total1::totals) rem in
|
(jumps_map ctx_combine total1::totals) rem in
|
||||||
|
|
@ -2298,7 +2298,7 @@ let rec lower_bind v arg lam = match lam with
|
||||||
and pnot = approx_present v ifnot in
|
and pnot = approx_present v ifnot in
|
||||||
begin match pcond, pso, pnot with
|
begin match pcond, pso, pnot with
|
||||||
| false, false, false -> lam
|
| false, false, false -> lam
|
||||||
| false, true, false ->
|
| false, true, false ->
|
||||||
Lifthenelse (cond, lower_bind v arg ifso, ifnot)
|
Lifthenelse (cond, lower_bind v arg ifso, ifnot)
|
||||||
| false, false, true ->
|
| false, false, true ->
|
||||||
Lifthenelse (cond, ifso, lower_bind v arg ifnot)
|
Lifthenelse (cond, ifso, lower_bind v arg ifnot)
|
||||||
|
|
@ -2315,19 +2315,19 @@ let rec lower_bind v arg lam = match lam with
|
||||||
bind Alias v arg lam
|
bind Alias v arg lam
|
||||||
else
|
else
|
||||||
Llet (Alias, vv, lv, lower_bind v arg l)
|
Llet (Alias, vv, lv, lower_bind v arg l)
|
||||||
| _ ->
|
| _ ->
|
||||||
bind Alias v arg lam
|
bind Alias v arg lam
|
||||||
|
|
||||||
let bind_check str v arg lam = match str,arg with
|
let bind_check str v arg lam = match str,arg with
|
||||||
| _, Lvar _ ->bind str v arg lam
|
| _, Lvar _ ->bind str v arg lam
|
||||||
| Alias,_ -> lower_bind v arg lam
|
| Alias,_ -> lower_bind v arg lam
|
||||||
| _,_ -> bind str v arg lam
|
| _,_ -> bind str v arg lam
|
||||||
|
|
||||||
let rec comp_exit ctx m = match m.default with
|
let rec comp_exit ctx m = match m.default with
|
||||||
| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx
|
| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx
|
||||||
| _ -> fatal_error "Matching.comp_exit"
|
| _ -> fatal_error "Matching.comp_exit"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = match next_matchs with
|
let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = match next_matchs with
|
||||||
| [] -> comp_fun partial ctx arg first_match
|
| [] -> comp_fun partial ctx arg first_match
|
||||||
|
|
@ -2336,7 +2336,7 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = m
|
||||||
| [] -> body, total_body
|
| [] -> body, total_body
|
||||||
(* Hum, -1 meant never taken
|
(* Hum, -1 meant never taken
|
||||||
| (-1,pm)::rem -> c_rec body total_body rem *)
|
| (-1,pm)::rem -> c_rec body total_body rem *)
|
||||||
| (i,pm)::rem ->
|
| (i,pm)::rem ->
|
||||||
let ctx_i,total_rem = jumps_extract i total_body in
|
let ctx_i,total_rem = jumps_extract i total_body in
|
||||||
begin match ctx_i with
|
begin match ctx_i with
|
||||||
| [] -> c_rec body total_body rem
|
| [] -> c_rec body total_body rem
|
||||||
|
|
@ -2424,7 +2424,7 @@ and do_compile_matching_pr repr partial ctx arg x =
|
||||||
pretty_ctx ctx ;
|
pretty_ctx ctx ;
|
||||||
let (_, jumps) as r = do_compile_matching repr partial ctx arg x in
|
let (_, jumps) as r = do_compile_matching repr partial ctx arg x in
|
||||||
prerr_endline "JUMPS" ;
|
prerr_endline "JUMPS" ;
|
||||||
pretty_jumps jumps ;
|
pretty_jumps jumps ;
|
||||||
r
|
r
|
||||||
*)
|
*)
|
||||||
and do_compile_matching repr partial ctx arg pmh = match pmh with
|
and do_compile_matching repr partial ctx arg pmh = match pmh with
|
||||||
|
|
@ -2432,7 +2432,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
|
||||||
let pat = what_is_cases pm.cases in
|
let pat = what_is_cases pm.cases in
|
||||||
begin match pat.pat_desc with
|
begin match pat.pat_desc with
|
||||||
| Tpat_any ->
|
| Tpat_any ->
|
||||||
compile_no_test
|
compile_no_test
|
||||||
divide_var ctx_rshift repr partial ctx pm
|
divide_var ctx_rshift repr partial ctx pm
|
||||||
| Tpat_tuple patl ->
|
| Tpat_tuple patl ->
|
||||||
compile_no_test
|
compile_no_test
|
||||||
|
|
@ -2453,7 +2453,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
|
||||||
(compile_match repr partial) partial
|
(compile_match repr partial) partial
|
||||||
divide_constructor (combine_constructor arg pat cstr partial)
|
divide_constructor (combine_constructor arg pat cstr partial)
|
||||||
ctx pm
|
ctx pm
|
||||||
| Tpat_array _ ->
|
| Tpat_array _ ->
|
||||||
let kind = Typeopt.array_pattern_kind pat in
|
let kind = Typeopt.array_pattern_kind pat in
|
||||||
compile_test (compile_match repr partial) partial
|
compile_test (compile_match repr partial) partial
|
||||||
(divide_array kind) (combine_array arg kind partial)
|
(divide_array kind) (combine_array arg kind partial)
|
||||||
|
|
@ -2499,7 +2499,7 @@ let check_partial pat_act_list partial =
|
||||||
(fun (_,lam) -> is_guarded lam)
|
(fun (_,lam) -> is_guarded lam)
|
||||||
pat_act_list
|
pat_act_list
|
||||||
then begin
|
then begin
|
||||||
Partial
|
Partial
|
||||||
end else
|
end else
|
||||||
partial
|
partial
|
||||||
|
|
||||||
|
|
@ -2590,7 +2590,7 @@ let for_tupled_function loc paraml pats_act_list partial =
|
||||||
|
|
||||||
let flatten_pattern size p = match p.pat_desc with
|
let flatten_pattern size p = match p.pat_desc with
|
||||||
| Tpat_tuple args -> args
|
| Tpat_tuple args -> args
|
||||||
| Tpat_any -> omegas size
|
| Tpat_any -> omegas size
|
||||||
| _ -> raise Cannot_flatten
|
| _ -> raise Cannot_flatten
|
||||||
|
|
||||||
let rec flatten_pat_line size p k = match p.pat_desc with
|
let rec flatten_pat_line size p k = match p.pat_desc with
|
||||||
|
|
@ -2666,7 +2666,7 @@ let do_for_multiple_match loc paraml pat_act_list partial =
|
||||||
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
|
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
|
||||||
args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ;
|
args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ;
|
||||||
default = [] } in
|
default = [] } in
|
||||||
|
|
||||||
try
|
try
|
||||||
try
|
try
|
||||||
(* Once for checking that compilation is possible *)
|
(* Once for checking that compilation is possible *)
|
||||||
|
|
@ -2683,7 +2683,7 @@ let do_for_multiple_match loc paraml pat_act_list partial =
|
||||||
nexts in
|
nexts in
|
||||||
|
|
||||||
let lam, total =
|
let lam, total =
|
||||||
comp_match_handlers
|
comp_match_handlers
|
||||||
(compile_flattened repr)
|
(compile_flattened repr)
|
||||||
partial (start_ctx size) () flat_next flat_nexts in
|
partial (start_ctx size) () flat_next flat_nexts in
|
||||||
List.fold_right2 (bind Strict) idl paraml
|
List.fold_right2 (bind Strict) idl paraml
|
||||||
|
|
@ -2728,4 +2728,3 @@ let for_multiple_match loc paraml pat_act_list partial =
|
||||||
let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in
|
let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in
|
||||||
List.fold_right bind_opt v_paraml
|
List.fold_right bind_opt v_paraml
|
||||||
(do_for_multiple_match loc paraml pat_act_list partial)
|
(do_for_multiple_match loc paraml pat_act_list partial)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -17,10 +17,11 @@ external realloc_global_data : int -> unit = "caml_realloc_global"
|
||||||
external static_alloc : int -> string = "caml_static_alloc"
|
external static_alloc : int -> string = "caml_static_alloc"
|
||||||
external static_free : string -> unit = "caml_static_free"
|
external static_free : string -> unit = "caml_static_free"
|
||||||
external static_resize : string -> int -> string = "caml_static_resize"
|
external static_resize : string -> int -> string = "caml_static_resize"
|
||||||
external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode"
|
external static_release_bytecode : string -> int -> unit
|
||||||
|
= "caml_static_release_bytecode"
|
||||||
type closure = unit -> Obj.t
|
type closure = unit -> Obj.t
|
||||||
external reify_bytecode : string -> int -> closure = "caml_reify_bytecode"
|
external reify_bytecode : string -> int -> closure = "caml_reify_bytecode"
|
||||||
external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
|
external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
|
||||||
= "caml_invoke_traced_function"
|
= "caml_invoke_traced_function"
|
||||||
external get_section_table : unit -> (string * Obj.t) list
|
external get_section_table : unit -> (string * Obj.t) list
|
||||||
= "caml_get_section_table"
|
= "caml_get_section_table"
|
||||||
|
|
|
||||||
|
|
@ -18,11 +18,12 @@ external global_data : unit -> Obj.t array = "caml_get_global_data"
|
||||||
external realloc_global_data : int -> unit = "caml_realloc_global"
|
external realloc_global_data : int -> unit = "caml_realloc_global"
|
||||||
external static_alloc : int -> string = "caml_static_alloc"
|
external static_alloc : int -> string = "caml_static_alloc"
|
||||||
external static_free : string -> unit = "caml_static_free"
|
external static_free : string -> unit = "caml_static_free"
|
||||||
external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode"
|
external static_release_bytecode : string -> int -> unit
|
||||||
|
= "caml_static_release_bytecode"
|
||||||
external static_resize : string -> int -> string = "caml_static_resize"
|
external static_resize : string -> int -> string = "caml_static_resize"
|
||||||
type closure = unit -> Obj.t
|
type closure = unit -> Obj.t
|
||||||
external reify_bytecode : string -> int -> closure = "caml_reify_bytecode"
|
external reify_bytecode : string -> int -> closure = "caml_reify_bytecode"
|
||||||
external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
|
external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
|
||||||
= "caml_invoke_traced_function"
|
= "caml_invoke_traced_function"
|
||||||
external get_section_table : unit -> (string * Obj.t) list
|
external get_section_table : unit -> (string * Obj.t) list
|
||||||
= "caml_get_section_table"
|
= "caml_get_section_table"
|
||||||
|
|
|
||||||
|
|
@ -26,7 +26,7 @@ let rec eliminate_ref id = function
|
||||||
Lvar v as lam ->
|
Lvar v as lam ->
|
||||||
if Ident.same v id then raise Real_reference else lam
|
if Ident.same v id then raise Real_reference else lam
|
||||||
| Lconst cst as lam -> lam
|
| Lconst cst as lam -> lam
|
||||||
| Lapply(e1, el, loc) ->
|
| Lapply(e1, el, loc) ->
|
||||||
Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc)
|
Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc)
|
||||||
| Lfunction(kind, params, body) as lam ->
|
| Lfunction(kind, params, body) as lam ->
|
||||||
if IdentSet.mem id (free_variables lam)
|
if IdentSet.mem id (free_variables lam)
|
||||||
|
|
@ -85,7 +85,7 @@ let rec eliminate_ref id = function
|
||||||
|
|
||||||
(* Simplification of exits *)
|
(* Simplification of exits *)
|
||||||
|
|
||||||
let simplify_exits lam =
|
let simplify_exits lam =
|
||||||
|
|
||||||
(* Count occurrences of (exit n ...) statements *)
|
(* Count occurrences of (exit n ...) statements *)
|
||||||
let exits = Hashtbl.create 17 in
|
let exits = Hashtbl.create 17 in
|
||||||
|
|
@ -101,7 +101,7 @@ let simplify_exits lam =
|
||||||
incr (Hashtbl.find exits i)
|
incr (Hashtbl.find exits i)
|
||||||
with
|
with
|
||||||
| Not_found -> Hashtbl.add exits i (ref 1) in
|
| Not_found -> Hashtbl.add exits i (ref 1) in
|
||||||
|
|
||||||
let rec count = function
|
let rec count = function
|
||||||
| (Lvar _| Lconst _) -> ()
|
| (Lvar _| Lconst _) -> ()
|
||||||
| Lapply(l1, ll, _) -> count l1; List.iter count ll
|
| Lapply(l1, ll, _) -> count l1; List.iter count ll
|
||||||
|
|
@ -267,7 +267,7 @@ let simplify_lets lam =
|
||||||
!(Hashtbl.find occ v)
|
!(Hashtbl.find occ v)
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
0
|
0
|
||||||
and incr_var v =
|
and incr_var v =
|
||||||
try
|
try
|
||||||
incr(Hashtbl.find occ v)
|
incr(Hashtbl.find occ v)
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
|
|
@ -388,7 +388,7 @@ let simplify_lets lam =
|
||||||
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
|
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
|
||||||
sw_failaction = new_fail})
|
sw_failaction = new_fail})
|
||||||
| Lstaticraise (i,ls) ->
|
| Lstaticraise (i,ls) ->
|
||||||
Lstaticraise (i, List.map simplif ls)
|
Lstaticraise (i, List.map simplif ls)
|
||||||
| Lstaticcatch(l1, (i,args), l2) ->
|
| Lstaticcatch(l1, (i,args), l2) ->
|
||||||
Lstaticcatch (simplif l1, (i,args), simplif l2)
|
Lstaticcatch (simplif l1, (i,args), simplif l2)
|
||||||
| Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
|
| Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
|
||||||
|
|
|
||||||
|
|
@ -20,7 +20,7 @@ let mk_store same =
|
||||||
let r_acts = ref [] in
|
let r_acts = ref [] in
|
||||||
let store act =
|
let store act =
|
||||||
let rec store_rec i = function
|
let rec store_rec i = function
|
||||||
| [] -> i,[act]
|
| [] -> i,[act]
|
||||||
| act0::rem ->
|
| act0::rem ->
|
||||||
if same act0 act then raise (Found i)
|
if same act0 act then raise (Found i)
|
||||||
else
|
else
|
||||||
|
|
@ -256,7 +256,7 @@ let coupe_inter i j cases =
|
||||||
Array.sub cases i (j-i+1),
|
Array.sub cases i (j-i+1),
|
||||||
case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1)))
|
case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1)))
|
||||||
|
|
||||||
type kind = Kvalue of int | Kinter of int | Kempty
|
type kind = Kvalue of int | Kinter of int | Kempty
|
||||||
|
|
||||||
let pkind chan = function
|
let pkind chan = function
|
||||||
| Kvalue i ->Printf.fprintf chan "V%d" i
|
| Kvalue i ->Printf.fprintf chan "V%d" i
|
||||||
|
|
@ -281,7 +281,7 @@ let make_key cases =
|
||||||
incr count ;
|
incr count ;
|
||||||
r
|
r
|
||||||
| (act0,index) :: rem ->
|
| (act0,index) :: rem ->
|
||||||
if act0 = act then
|
if act0 = act then
|
||||||
index
|
index
|
||||||
else
|
else
|
||||||
got_it act rem in
|
got_it act rem in
|
||||||
|
|
@ -291,7 +291,7 @@ let make_key cases =
|
||||||
Kvalue (got_it act !seen)
|
Kvalue (got_it act !seen)
|
||||||
else
|
else
|
||||||
Kinter (got_it act !seen) in
|
Kinter (got_it act !seen) in
|
||||||
|
|
||||||
let rec make_rec i pl =
|
let rec make_rec i pl =
|
||||||
if i < 0 then
|
if i < 0 then
|
||||||
[]
|
[]
|
||||||
|
|
@ -303,8 +303,8 @@ let make_key cases =
|
||||||
Kempty::make_one l h act::make_rec (i-1) l in
|
Kempty::make_one l h act::make_rec (i-1) l in
|
||||||
|
|
||||||
let l,h,act = cases.(Array.length cases-1) in
|
let l,h,act = cases.(Array.length cases-1) in
|
||||||
make_one l h act::make_rec (Array.length cases-2) l
|
make_one l h act::make_rec (Array.length cases-2) l
|
||||||
|
|
||||||
|
|
||||||
let same_act t =
|
let same_act t =
|
||||||
let len = Array.length t in
|
let len = Array.length t in
|
||||||
|
|
@ -330,7 +330,7 @@ let make_key cases =
|
||||||
|
|
||||||
This condition is checked by zyva
|
This condition is checked by zyva
|
||||||
*)
|
*)
|
||||||
|
|
||||||
let inter_limit = 1 lsl 16
|
let inter_limit = 1 lsl 16
|
||||||
|
|
||||||
let ok_inter = ref false
|
let ok_inter = ref false
|
||||||
|
|
@ -356,7 +356,7 @@ let rec opt_count top cases =
|
||||||
divide top cases in
|
divide top cases in
|
||||||
Hashtbl.add t key r ;
|
Hashtbl.add t key r ;
|
||||||
r
|
r
|
||||||
|
|
||||||
and divide top cases =
|
and divide top cases =
|
||||||
let lcases = Array.length cases in
|
let lcases = Array.length cases in
|
||||||
let m = lcases/2 in
|
let m = lcases/2 in
|
||||||
|
|
@ -372,12 +372,12 @@ and divide top cases =
|
||||||
else
|
else
|
||||||
add_test cm cml ;
|
add_test cm cml ;
|
||||||
Sep m,(cm, ci)
|
Sep m,(cm, ci)
|
||||||
|
|
||||||
and heuristic top cases =
|
and heuristic top cases =
|
||||||
let lcases = Array.length cases in
|
let lcases = Array.length cases in
|
||||||
|
|
||||||
let sep,csep = divide false cases
|
let sep,csep = divide false cases
|
||||||
|
|
||||||
and inter,cinter =
|
and inter,cinter =
|
||||||
if !ok_inter then begin
|
if !ok_inter then begin
|
||||||
let _,_,act0 = cases.(0)
|
let _,_,act0 = cases.(0)
|
||||||
|
|
@ -398,18 +398,18 @@ and heuristic top cases =
|
||||||
end else
|
end else
|
||||||
Inter (-1,-1),(too_much, too_much)
|
Inter (-1,-1),(too_much, too_much)
|
||||||
end else
|
end else
|
||||||
Inter (-1,-1),(too_much, too_much) in
|
Inter (-1,-1),(too_much, too_much) in
|
||||||
if less2tests csep cinter then
|
if less2tests csep cinter then
|
||||||
sep,csep
|
sep,csep
|
||||||
else
|
else
|
||||||
inter,cinter
|
inter,cinter
|
||||||
|
|
||||||
|
|
||||||
and enum top cases =
|
and enum top cases =
|
||||||
let lcases = Array.length cases in
|
let lcases = Array.length cases in
|
||||||
let lim, with_sep =
|
let lim, with_sep =
|
||||||
let best = ref (-1) and best_cost = ref (too_much,too_much) in
|
let best = ref (-1) and best_cost = ref (too_much,too_much) in
|
||||||
|
|
||||||
for i = 1 to lcases-(1) do
|
for i = 1 to lcases-(1) do
|
||||||
let _,left,right = coupe cases i in
|
let _,left,right = coupe cases i in
|
||||||
let ci = {n=1 ; ni=0}
|
let ci = {n=1 ; ni=0}
|
||||||
|
|
@ -422,7 +422,7 @@ and enum top cases =
|
||||||
add_test cm cmr
|
add_test cm cmr
|
||||||
else
|
else
|
||||||
add_test cm cml ;
|
add_test cm cml ;
|
||||||
|
|
||||||
if
|
if
|
||||||
less2tests (cm,ci) !best_cost
|
less2tests (cm,ci) !best_cost
|
||||||
then begin
|
then begin
|
||||||
|
|
@ -488,45 +488,45 @@ and enum top cases =
|
||||||
r := Sep lim ; rc := with_sep
|
r := Sep lim ; rc := with_sep
|
||||||
end ;
|
end ;
|
||||||
!r, !rc
|
!r, !rc
|
||||||
|
|
||||||
let make_if_test konst test arg i ifso ifnot =
|
let make_if_test konst test arg i ifso ifnot =
|
||||||
Arg.make_if
|
Arg.make_if
|
||||||
(Arg.make_prim test [arg ; konst i])
|
(Arg.make_prim test [arg ; konst i])
|
||||||
ifso ifnot
|
ifso ifnot
|
||||||
|
|
||||||
let make_if_lt konst arg i ifso ifnot = match i with
|
let make_if_lt konst arg i ifso ifnot = match i with
|
||||||
| 1 ->
|
| 1 ->
|
||||||
make_if_test konst Arg.leint arg 0 ifso ifnot
|
make_if_test konst Arg.leint arg 0 ifso ifnot
|
||||||
| _ ->
|
| _ ->
|
||||||
make_if_test konst Arg.ltint arg i ifso ifnot
|
make_if_test konst Arg.ltint arg i ifso ifnot
|
||||||
|
|
||||||
and make_if_le konst arg i ifso ifnot = match i with
|
and make_if_le konst arg i ifso ifnot = match i with
|
||||||
| -1 ->
|
| -1 ->
|
||||||
make_if_test konst Arg.ltint arg 0 ifso ifnot
|
make_if_test konst Arg.ltint arg 0 ifso ifnot
|
||||||
| _ ->
|
| _ ->
|
||||||
make_if_test konst Arg.leint arg i ifso ifnot
|
make_if_test konst Arg.leint arg i ifso ifnot
|
||||||
|
|
||||||
and make_if_gt konst arg i ifso ifnot = match i with
|
and make_if_gt konst arg i ifso ifnot = match i with
|
||||||
| -1 ->
|
| -1 ->
|
||||||
make_if_test konst Arg.geint arg 0 ifso ifnot
|
make_if_test konst Arg.geint arg 0 ifso ifnot
|
||||||
| _ ->
|
| _ ->
|
||||||
make_if_test konst Arg.gtint arg i ifso ifnot
|
make_if_test konst Arg.gtint arg i ifso ifnot
|
||||||
|
|
||||||
and make_if_ge konst arg i ifso ifnot = match i with
|
and make_if_ge konst arg i ifso ifnot = match i with
|
||||||
| 1 ->
|
| 1 ->
|
||||||
make_if_test konst Arg.gtint arg 0 ifso ifnot
|
make_if_test konst Arg.gtint arg 0 ifso ifnot
|
||||||
| _ ->
|
| _ ->
|
||||||
make_if_test konst Arg.geint arg i ifso ifnot
|
make_if_test konst Arg.geint arg i ifso ifnot
|
||||||
|
|
||||||
and make_if_eq konst arg i ifso ifnot =
|
and make_if_eq konst arg i ifso ifnot =
|
||||||
make_if_test konst Arg.eqint arg i ifso ifnot
|
make_if_test konst Arg.eqint arg i ifso ifnot
|
||||||
|
|
||||||
and make_if_ne konst arg i ifso ifnot =
|
and make_if_ne konst arg i ifso ifnot =
|
||||||
make_if_test konst Arg.neint arg i ifso ifnot
|
make_if_test konst Arg.neint arg i ifso ifnot
|
||||||
|
|
||||||
let do_make_if_out h arg ifso ifno =
|
let do_make_if_out h arg ifso ifno =
|
||||||
Arg.make_if (Arg.make_isout 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 konst ctx l d mk_ifso mk_ifno = match l with
|
||||||
| 0 ->
|
| 0 ->
|
||||||
do_make_if_out
|
do_make_if_out
|
||||||
|
|
@ -538,10 +538,10 @@ and enum top cases =
|
||||||
let ctx = {off= (-l+ctx.off) ; arg=arg} in
|
let ctx = {off= (-l+ctx.off) ; arg=arg} in
|
||||||
do_make_if_out
|
do_make_if_out
|
||||||
(konst d) arg (mk_ifso ctx) (mk_ifno ctx))
|
(konst d) arg (mk_ifso ctx) (mk_ifno ctx))
|
||||||
|
|
||||||
let do_make_if_in h arg ifso ifno =
|
let do_make_if_in h arg ifso ifno =
|
||||||
Arg.make_if (Arg.make_isin 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 konst ctx l d mk_ifso mk_ifno = match l with
|
||||||
| 0 ->
|
| 0 ->
|
||||||
do_make_if_in
|
do_make_if_in
|
||||||
|
|
@ -553,15 +553,15 @@ and enum top cases =
|
||||||
let ctx = {off= (-l+ctx.off) ; arg=arg} in
|
let ctx = {off= (-l+ctx.off) ; arg=arg} in
|
||||||
do_make_if_in
|
do_make_if_in
|
||||||
(konst d) arg (mk_ifso ctx) (mk_ifno ctx))
|
(konst d) arg (mk_ifso ctx) (mk_ifno ctx))
|
||||||
|
|
||||||
|
|
||||||
let rec c_test konst ctx ({cases=cases ; actions=actions} as s) =
|
let rec c_test konst ctx ({cases=cases ; actions=actions} as s) =
|
||||||
let lcases = Array.length cases in
|
let lcases = Array.length cases in
|
||||||
assert(lcases > 0) ;
|
assert(lcases > 0) ;
|
||||||
if lcases = 1 then
|
if lcases = 1 then
|
||||||
actions.(get_act cases 0) ctx
|
actions.(get_act cases 0) ctx
|
||||||
else begin
|
else begin
|
||||||
|
|
||||||
let w,c = opt_count false cases in
|
let w,c = opt_count false cases in
|
||||||
(*
|
(*
|
||||||
Printf.fprintf stderr
|
Printf.fprintf stderr
|
||||||
|
|
@ -624,7 +624,7 @@ and enum top cases =
|
||||||
make_if_ge konst
|
make_if_ge konst
|
||||||
ctx.arg (lim+ctx.off)
|
ctx.arg (lim+ctx.off)
|
||||||
(c_test konst ctx right) (c_test konst ctx left)
|
(c_test konst ctx right) (c_test konst ctx left)
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -687,7 +687,7 @@ let comp_clusters ({cases=cases ; actions=actions} as s) =
|
||||||
get_min (j-1) + 1 < min_clusters.(i)
|
get_min (j-1) + 1 < min_clusters.(i)
|
||||||
then begin
|
then begin
|
||||||
k.(i) <- j ;
|
k.(i) <- j ;
|
||||||
min_clusters.(i) <- get_min (j-1) + 1
|
min_clusters.(i) <- get_min (j-1) + 1
|
||||||
end
|
end
|
||||||
done ;
|
done ;
|
||||||
done ;
|
done ;
|
||||||
|
|
@ -766,15 +766,15 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
|
||||||
r.(ir) <- (l,h,add_index (make_switch s i j))
|
r.(ir) <- (l,h,add_index (make_switch s i j))
|
||||||
end ;
|
end ;
|
||||||
if i > 0 then zyva (i-1) (ir-1) in
|
if i > 0 then zyva (i-1) (ir-1) in
|
||||||
|
|
||||||
zyva (len-1) (n_clusters-1) ;
|
zyva (len-1) (n_clusters-1) ;
|
||||||
let acts = Array.create !index (fun _ -> assert false) in
|
let acts = Array.create !index (fun _ -> assert false) in
|
||||||
Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
|
Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
|
||||||
{cases = r ; actions = acts}
|
{cases = r ; actions = acts}
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
|
||||||
let zyva (low,high) konst arg cases actions =
|
let zyva (low,high) konst arg cases actions =
|
||||||
let old_ok = !ok_inter in
|
let old_ok = !ok_inter in
|
||||||
ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
|
ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
|
||||||
if !ok_inter <> old_ok then Hashtbl.clear t ;
|
if !ok_inter <> old_ok then Hashtbl.clear t ;
|
||||||
|
|
@ -793,7 +793,7 @@ let zyva (low,high) konst arg cases actions =
|
||||||
|
|
||||||
|
|
||||||
and test_sequence konst arg cases actions =
|
and test_sequence konst arg cases actions =
|
||||||
let old_ok = !ok_inter in
|
let old_ok = !ok_inter in
|
||||||
ok_inter := false ;
|
ok_inter := false ;
|
||||||
if !ok_inter <> old_ok then Hashtbl.clear t ;
|
if !ok_inter <> old_ok then Hashtbl.clear t ;
|
||||||
let s =
|
let s =
|
||||||
|
|
|
||||||
|
|
@ -67,7 +67,7 @@ module Make :
|
||||||
functor (Arg : S) ->
|
functor (Arg : S) ->
|
||||||
sig
|
sig
|
||||||
val zyva :
|
val zyva :
|
||||||
(int * int) ->
|
(int * int) ->
|
||||||
(int -> Arg.act) ->
|
(int -> Arg.act) ->
|
||||||
Arg.act ->
|
Arg.act ->
|
||||||
(int * int * int) array ->
|
(int * int * int) array ->
|
||||||
|
|
|
||||||
|
|
@ -133,8 +133,8 @@ let output_primitive_table outchan =
|
||||||
|
|
||||||
let init () =
|
let init () =
|
||||||
(* Enter the predefined exceptions *)
|
(* Enter the predefined exceptions *)
|
||||||
Array.iter
|
Array.iter
|
||||||
(fun name ->
|
(fun name ->
|
||||||
let id =
|
let id =
|
||||||
try List.assoc name Predef.builtin_values
|
try List.assoc name Predef.builtin_values
|
||||||
with Not_found -> fatal_error "Symtable.init" in
|
with Not_found -> fatal_error "Symtable.init" in
|
||||||
|
|
@ -180,7 +180,7 @@ let patch_int buff pos n =
|
||||||
String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
|
String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
|
||||||
String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
|
String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
|
||||||
|
|
||||||
let patch_object buff patchlist =
|
let patch_object buff patchlist =
|
||||||
List.iter
|
List.iter
|
||||||
(function
|
(function
|
||||||
(Reloc_literal sc, pos) ->
|
(Reloc_literal sc, pos) ->
|
||||||
|
|
@ -249,7 +249,7 @@ let update_global_table () =
|
||||||
(* Recover data for toplevel initialization. Data can come either from
|
(* Recover data for toplevel initialization. Data can come either from
|
||||||
executable file (normal case) or from linked-in data (-output-obj). *)
|
executable file (normal case) or from linked-in data (-output-obj). *)
|
||||||
|
|
||||||
type section_reader = {
|
type section_reader = {
|
||||||
read_string: string -> string;
|
read_string: string -> string;
|
||||||
read_struct: string -> Obj.t;
|
read_struct: string -> Obj.t;
|
||||||
close_reader: unit -> unit
|
close_reader: unit -> unit
|
||||||
|
|
@ -262,7 +262,7 @@ let read_sections () =
|
||||||
(fun name -> (Obj.magic(List.assoc name sections) : string));
|
(fun name -> (Obj.magic(List.assoc name sections) : string));
|
||||||
read_struct =
|
read_struct =
|
||||||
(fun name -> List.assoc name sections);
|
(fun name -> List.assoc name sections);
|
||||||
close_reader =
|
close_reader =
|
||||||
(fun () -> ()) }
|
(fun () -> ()) }
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
let ic = open_in_bin Sys.executable_name in
|
let ic = open_in_bin Sys.executable_name in
|
||||||
|
|
|
||||||
|
|
@ -84,7 +84,7 @@ let primitive_declarations = ref ([] : Primitive.description list)
|
||||||
let record_primitive = function
|
let record_primitive = function
|
||||||
| {val_kind=Val_prim p} -> primitive_declarations := p :: !primitive_declarations
|
| {val_kind=Val_prim p} -> primitive_declarations := p :: !primitive_declarations
|
||||||
| _ -> ()
|
| _ -> ()
|
||||||
|
|
||||||
(* Keep track of the root path (from the root of the namespace to the
|
(* Keep track of the root path (from the root of the namespace to the
|
||||||
currently compiled module expression). Useful for naming exceptions. *)
|
currently compiled module expression). Useful for naming exceptions. *)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@ val transl_store_phrases: string -> structure -> int * lambda
|
||||||
val transl_store_implementation:
|
val transl_store_implementation:
|
||||||
string -> structure * module_coercion -> int * lambda
|
string -> structure * module_coercion -> int * lambda
|
||||||
val transl_toplevel_definition: structure -> lambda
|
val transl_toplevel_definition: structure -> lambda
|
||||||
val transl_package:
|
val transl_package:
|
||||||
Ident.t option list -> Ident.t -> module_coercion -> lambda
|
Ident.t option list -> Ident.t -> module_coercion -> lambda
|
||||||
val transl_store_package:
|
val transl_store_package:
|
||||||
Ident.t option list -> Ident.t -> module_coercion -> int * lambda
|
Ident.t option list -> Ident.t -> module_coercion -> int * lambda
|
||||||
|
|
|
||||||
|
|
@ -112,8 +112,8 @@ let transl_store_label_init glob size f arg =
|
||||||
(size+1,
|
(size+1,
|
||||||
Lsequence(
|
Lsequence(
|
||||||
Lprim(Psetfield(size, false),
|
Lprim(Psetfield(size, false),
|
||||||
[Lprim(Pgetglobal glob, []);
|
[Lprim(Pgetglobal glob, []);
|
||||||
Lprim (Pccall prim_makearray, [int !method_count; int 0])]),
|
Lprim (Pccall prim_makearray, [int !method_count; int 0])]),
|
||||||
expr))
|
expr))
|
||||||
in
|
in
|
||||||
(size, transl_label_init expr)
|
(size, transl_label_init expr)
|
||||||
|
|
@ -157,4 +157,3 @@ let oo_wrap env req f x =
|
||||||
wrapping := false;
|
wrapping := false;
|
||||||
top_env := Env.empty;
|
top_env := Env.empty;
|
||||||
raise exn
|
raise exn
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -58,7 +58,7 @@ let array_element_kind env ty =
|
||||||
else if Path.same p Predef.path_float then
|
else if Path.same p Predef.path_float then
|
||||||
Pfloatarray
|
Pfloatarray
|
||||||
else if Path.same p Predef.path_string
|
else if Path.same p Predef.path_string
|
||||||
|| Path.same p Predef.path_array
|
|| Path.same p Predef.path_array
|
||||||
|| Path.same p Predef.path_nativeint
|
|| Path.same p Predef.path_nativeint
|
||||||
|| Path.same p Predef.path_int32
|
|| Path.same p Predef.path_int32
|
||||||
|| Path.same p Predef.path_int64 then
|
|| Path.same p Predef.path_int64 then
|
||||||
|
|
|
||||||
|
|
@ -22,7 +22,7 @@ OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O)
|
||||||
DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO)
|
DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO)
|
||||||
|
|
||||||
ocamlrun$(EXE): libcamlrun.$(A) prims.$(O)
|
ocamlrun$(EXE): libcamlrun.$(A) prims.$(O)
|
||||||
$(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrun.$(A)
|
$(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrun.$(A)
|
||||||
|
|
||||||
ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O)
|
ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O)
|
||||||
$(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A)
|
$(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A)
|
||||||
|
|
|
||||||
|
|
@ -34,7 +34,7 @@ CAMLprim value caml_array_get_float(value array, value index)
|
||||||
double d;
|
double d;
|
||||||
value res;
|
value res;
|
||||||
|
|
||||||
if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
|
if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
|
||||||
caml_array_bound_error();
|
caml_array_bound_error();
|
||||||
d = Double_field(array, idx);
|
d = Double_field(array, idx);
|
||||||
#define Setup_for_gc
|
#define Setup_for_gc
|
||||||
|
|
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue