From 8e013d68bafc06ba3821486895a690c920b5851a Mon Sep 17 00:00:00 2001 From: CentOS Sources Date: Apr 10 2018 05:23:00 +0000 Subject: import ocaml-4.05.0-6.el7 --- diff --git a/.gitignore b/.gitignore index fd9ef47..17a0546 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,4 @@ -SOURCES/ocaml-4.01-refman-html.tar.gz -SOURCES/ocaml-4.01-refman.info.tar.gz -SOURCES/ocaml-4.01-refman.pdf -SOURCES/ocaml-ecc80c0d3850bc144760af4c63b7eab438615bdc.tar.gz +SOURCES/ocaml-4.05-refman-html.tar.gz +SOURCES/ocaml-4.05-refman.info.tar.gz +SOURCES/ocaml-4.05-refman.pdf +SOURCES/ocaml-4.05.0.tar.xz diff --git a/.ocaml.metadata b/.ocaml.metadata index 47bcc51..0531a5b 100644 --- a/.ocaml.metadata +++ b/.ocaml.metadata @@ -1,4 +1,4 @@ -cd8d59ca75525c0dfa3cfaa29477c4ea5fa1c839 SOURCES/ocaml-4.01-refman-html.tar.gz -f5aa5bb8bc07899f5414de0d31af0d5a0168b002 SOURCES/ocaml-4.01-refman.info.tar.gz -be0d11b3efeca305cc9c561ba74a3819b0dda4e8 SOURCES/ocaml-4.01-refman.pdf -089e23a33b29e20a4e3bdfd9a5fcc6b501654c29 SOURCES/ocaml-ecc80c0d3850bc144760af4c63b7eab438615bdc.tar.gz +1fa154769c893c9ccf615c00b0ae81386240ef25 SOURCES/ocaml-4.05-refman-html.tar.gz +9374cd940da70493709dfb5f3ea5dc86febea27a SOURCES/ocaml-4.05-refman.info.tar.gz +98d4599d04a5fb07b739eef4a2c318df7f01d73f SOURCES/ocaml-4.05-refman.pdf +948dcedf0e33b7be4bb573874a8d57caec0f8b43 SOURCES/ocaml-4.05.0.tar.xz diff --git a/SOURCES/0001-Add-.gitignore-file-to-ignore-generated-files.patch b/SOURCES/0001-Add-.gitignore-file-to-ignore-generated-files.patch deleted file mode 100644 index f84af2a..0000000 --- a/SOURCES/0001-Add-.gitignore-file-to-ignore-generated-files.patch +++ /dev/null @@ -1,367 +0,0 @@ -From 3e74f2acd0b5a41f0faa33c770740cb74c89d257 Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Thu, 7 Jun 2012 16:00:28 +0100 -Subject: [PATCH 01/19] Add .gitignore file to ignore generated files. - ---- - .gitignore | 348 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - 1 file changed, 348 insertions(+) - create mode 100644 .gitignore - -diff --git a/.gitignore b/.gitignore -new file mode 100644 -index 0000000..20a181f ---- /dev/null -+++ b/.gitignore -@@ -0,0 +1,348 @@ -+*~ -+*.a -+*.bak -+*.cma -+*.cmi -+*.cmo -+*.cmx -+*.o -+*.so -+/_boot_log1 -+/_boot_log2 -+/_build/ -+/_log -+/asmcomp/arch.ml -+/asmcomp/emit.ml -+/asmcomp/proc.ml -+/asmcomp/reload.ml -+/asmcomp/scheduling.ml -+/asmcomp/selection.ml -+/asmrun/alloc.c -+/asmrun/array.c -+/asmrun/callback.c -+/asmrun/compact.c -+/asmrun/compare.c -+/asmrun/custom.c -+/asmrun/debugger.c -+/asmrun/dynlink.c -+/asmrun/extern.c -+/asmrun/finalise.c -+/asmrun/floats.c -+/asmrun/freelist.c -+/asmrun/gc_ctrl.c -+/asmrun/globroots.c -+/asmrun/hash.c -+/asmrun/intern.c -+/asmrun/ints.c -+/asmrun/io.c -+/asmrun/lexing.c -+/asmrun/main.c -+/asmrun/major_gc.c -+/asmrun/md5.c -+/asmrun/memory.c -+/asmrun/meta.c -+/asmrun/minor_gc.c -+/asmrun/misc.c -+/asmrun/obj.c -+/asmrun/parsing.c -+/asmrun/printexc.c -+/asmrun/signals.c -+/asmrun/str.c -+/asmrun/sys.c -+/asmrun/terminfo.c -+/asmrun/unix.c -+/asmrun/weak.c -+/boot/camlheader -+/boot/myocamlbuild -+/boot/ocamlrun -+/boot/ocamlyacc -+/build/ocamlbuild_mixed_mode -+/bytecomp/opcodes.ml -+/bytecomp/runtimedef.ml -+/byterun/jumptbl.h -+/byterun/ld.conf -+/byterun/ocamlrun -+/byterun/primitives -+/byterun/prims.c -+/byterun/version.h -+/compilerlibs/ocamlbytecomp.cmxa -+/compilerlibs/ocamlcommon.cmxa -+/compilerlibs/ocamloptcomp.cmxa -+/configure -+/config/Makefile -+/config/config.sh -+/config/m.h -+/config/s.h -+/debugger/dynlink.ml -+/debugger/dynlink.mli -+/debugger/lexer.ml -+/debugger/ocamldebug -+/debugger/parser.ml -+/debugger/parser.mli -+/expunge -+/lex/lexer.ml -+/lex/ocamllex -+/lex/ocamllex.opt -+/lex/parser.ml -+/lex/parser.mli -+/lex/parser.output -+/myocamlbuild_config.ml -+/ocamlbuild-mixed-boot -+/ocaml -+/ocamlc -+/ocamlc.opt -+/ocamlcomp.sh -+/ocamlcompopt.sh -+/ocamldoc/generators/odoc_literate.cmxs -+/ocamldoc/generators/odoc_todo.cmxs -+/ocamldoc/ocamldoc -+/ocamldoc/ocamldoc.opt -+/ocamldoc/odoc_info.cmxa -+/ocamldoc/odoc_lexer.ml -+/ocamldoc/odoc_ocamlhtml.ml -+/ocamldoc/odoc_parser.ml -+/ocamldoc/odoc_parser.mli -+/ocamldoc/odoc_parser.output -+/ocamldoc/odoc_see_lexer.ml -+/ocamldoc/odoc_text_lexer.ml -+/ocamldoc/odoc_text_parser.ml -+/ocamldoc/odoc_text_parser.mli -+/ocamldoc/odoc_text_parser.output -+/ocamldoc/stdlib_man/ -+/ocamlnat -+/ocamlopt -+/ocamlopt.opt -+/otherlibs/bigarray/bigarray.cmxa -+/otherlibs/bigarray/bigarray.cmxs -+/otherlibs/dynlink/dynlink.cmxa -+/otherlibs/dbm/ -+/otherlibs/dynlink/extract_crc -+/otherlibs/graph/graphics.cmxa -+/otherlibs/graph/graphics.cmxs -+/otherlibs/labltk/frx/frxlib.cmxa -+/otherlibs/labltk/jpf/jpflib.cmxa -+/otherlibs/labltk/lib/labltk.cmxa -+/otherlibs/labltk/browser/dummy.mli -+/otherlibs/labltk/browser/help.ml -+/otherlibs/labltk/browser/ocamlbrowser -+/otherlibs/labltk/camltk/.depend -+/otherlibs/labltk/camltk/_tkfgen.ml -+/otherlibs/labltk/camltk/_tkgen.ml -+/otherlibs/labltk/camltk/_tkgen.mli -+/otherlibs/labltk/camltk/_tkigen.ml -+/otherlibs/labltk/camltk/cBell.ml -+/otherlibs/labltk/camltk/cBell.mli -+/otherlibs/labltk/camltk/cButton.ml -+/otherlibs/labltk/camltk/cButton.mli -+/otherlibs/labltk/camltk/cCanvas.ml -+/otherlibs/labltk/camltk/cCanvas.mli -+/otherlibs/labltk/camltk/cCheckbutton.ml -+/otherlibs/labltk/camltk/cCheckbutton.mli -+/otherlibs/labltk/camltk/cClipboard.ml -+/otherlibs/labltk/camltk/cClipboard.mli -+/otherlibs/labltk/camltk/cDialog.ml -+/otherlibs/labltk/camltk/cDialog.mli -+/otherlibs/labltk/camltk/cEncoding.ml -+/otherlibs/labltk/camltk/cEncoding.mli -+/otherlibs/labltk/camltk/cEntry.ml -+/otherlibs/labltk/camltk/cEntry.mli -+/otherlibs/labltk/camltk/cFocus.ml -+/otherlibs/labltk/camltk/cFocus.mli -+/otherlibs/labltk/camltk/cFont.ml -+/otherlibs/labltk/camltk/cFont.mli -+/otherlibs/labltk/camltk/cFrame.ml -+/otherlibs/labltk/camltk/cFrame.mli -+/otherlibs/labltk/camltk/cGrab.ml -+/otherlibs/labltk/camltk/cGrab.mli -+/otherlibs/labltk/camltk/cGrid.ml -+/otherlibs/labltk/camltk/cGrid.mli -+/otherlibs/labltk/camltk/cImage.ml -+/otherlibs/labltk/camltk/cImage.mli -+/otherlibs/labltk/camltk/cImagebitmap.ml -+/otherlibs/labltk/camltk/cImagebitmap.mli -+/otherlibs/labltk/camltk/cImagephoto.ml -+/otherlibs/labltk/camltk/cImagephoto.mli -+/otherlibs/labltk/camltk/cLabel.ml -+/otherlibs/labltk/camltk/cLabel.mli -+/otherlibs/labltk/camltk/cListbox.ml -+/otherlibs/labltk/camltk/cListbox.mli -+/otherlibs/labltk/camltk/cMenu.ml -+/otherlibs/labltk/camltk/cMenu.mli -+/otherlibs/labltk/camltk/cMenubutton.ml -+/otherlibs/labltk/camltk/cMenubutton.mli -+/otherlibs/labltk/camltk/cMessage.ml -+/otherlibs/labltk/camltk/cMessage.mli -+/otherlibs/labltk/camltk/cOption.ml -+/otherlibs/labltk/camltk/cOption.mli -+/otherlibs/labltk/camltk/cOptionmenu.ml -+/otherlibs/labltk/camltk/cOptionmenu.mli -+/otherlibs/labltk/camltk/cPack.ml -+/otherlibs/labltk/camltk/cPack.mli -+/otherlibs/labltk/camltk/cPalette.ml -+/otherlibs/labltk/camltk/cPalette.mli -+/otherlibs/labltk/camltk/cPixmap.ml -+/otherlibs/labltk/camltk/cPixmap.mli -+/otherlibs/labltk/camltk/cPlace.ml -+/otherlibs/labltk/camltk/cPlace.mli -+/otherlibs/labltk/camltk/cRadiobutton.ml -+/otherlibs/labltk/camltk/cRadiobutton.mli -+/otherlibs/labltk/camltk/cResource.ml -+/otherlibs/labltk/camltk/cResource.mli -+/otherlibs/labltk/camltk/cScale.ml -+/otherlibs/labltk/camltk/cScale.mli -+/otherlibs/labltk/camltk/cScrollbar.ml -+/otherlibs/labltk/camltk/cScrollbar.mli -+/otherlibs/labltk/camltk/cSelection.ml -+/otherlibs/labltk/camltk/cSelection.mli -+/otherlibs/labltk/camltk/cText.ml -+/otherlibs/labltk/camltk/cText.mli -+/otherlibs/labltk/camltk/cTk.ml -+/otherlibs/labltk/camltk/cTkvars.ml -+/otherlibs/labltk/camltk/cTkvars.mli -+/otherlibs/labltk/camltk/cTkwait.ml -+/otherlibs/labltk/camltk/cTkwait.mli -+/otherlibs/labltk/camltk/cToplevel.ml -+/otherlibs/labltk/camltk/cToplevel.mli -+/otherlibs/labltk/camltk/cWinfo.ml -+/otherlibs/labltk/camltk/cWinfo.mli -+/otherlibs/labltk/camltk/cWm.ml -+/otherlibs/labltk/camltk/cWm.mli -+/otherlibs/labltk/camltk/camltk.ml -+/otherlibs/labltk/compiler/copyright.ml -+/otherlibs/labltk/compiler/lexer.ml -+/otherlibs/labltk/compiler/parser.ml -+/otherlibs/labltk/compiler/parser.mli -+/otherlibs/labltk/compiler/parser.output -+/otherlibs/labltk/compiler/pp -+/otherlibs/labltk/compiler/pplex.ml -+/otherlibs/labltk/compiler/ppyac.ml -+/otherlibs/labltk/compiler/ppyac.mli -+/otherlibs/labltk/compiler/ppyac.output -+/otherlibs/labltk/compiler/tkcompiler -+/otherlibs/labltk/labltk/.depend -+/otherlibs/labltk/labltk/_tkfgen.ml -+/otherlibs/labltk/labltk/_tkgen.ml -+/otherlibs/labltk/labltk/_tkgen.mli -+/otherlibs/labltk/labltk/_tkigen.ml -+/otherlibs/labltk/labltk/bell.ml -+/otherlibs/labltk/labltk/bell.mli -+/otherlibs/labltk/labltk/button.ml -+/otherlibs/labltk/labltk/button.mli -+/otherlibs/labltk/labltk/canvas.ml -+/otherlibs/labltk/labltk/canvas.mli -+/otherlibs/labltk/labltk/checkbutton.ml -+/otherlibs/labltk/labltk/checkbutton.mli -+/otherlibs/labltk/labltk/clipboard.ml -+/otherlibs/labltk/labltk/clipboard.mli -+/otherlibs/labltk/labltk/dialog.ml -+/otherlibs/labltk/labltk/dialog.mli -+/otherlibs/labltk/labltk/encoding.ml -+/otherlibs/labltk/labltk/encoding.mli -+/otherlibs/labltk/labltk/entry.ml -+/otherlibs/labltk/labltk/entry.mli -+/otherlibs/labltk/labltk/focus.ml -+/otherlibs/labltk/labltk/focus.mli -+/otherlibs/labltk/labltk/font.ml -+/otherlibs/labltk/labltk/font.mli -+/otherlibs/labltk/labltk/frame.ml -+/otherlibs/labltk/labltk/frame.mli -+/otherlibs/labltk/labltk/grab.ml -+/otherlibs/labltk/labltk/grab.mli -+/otherlibs/labltk/labltk/grid.ml -+/otherlibs/labltk/labltk/grid.mli -+/otherlibs/labltk/labltk/image.ml -+/otherlibs/labltk/labltk/image.mli -+/otherlibs/labltk/labltk/imagebitmap.ml -+/otherlibs/labltk/labltk/imagebitmap.mli -+/otherlibs/labltk/labltk/imagephoto.ml -+/otherlibs/labltk/labltk/imagephoto.mli -+/otherlibs/labltk/labltk/label.ml -+/otherlibs/labltk/labltk/label.mli -+/otherlibs/labltk/labltk/labltk.ml -+/otherlibs/labltk/labltk/listbox.ml -+/otherlibs/labltk/labltk/listbox.mli -+/otherlibs/labltk/labltk/menu.ml -+/otherlibs/labltk/labltk/menu.mli -+/otherlibs/labltk/labltk/menubutton.ml -+/otherlibs/labltk/labltk/menubutton.mli -+/otherlibs/labltk/labltk/message.ml -+/otherlibs/labltk/labltk/message.mli -+/otherlibs/labltk/labltk/option.ml -+/otherlibs/labltk/labltk/option.mli -+/otherlibs/labltk/labltk/optionmenu.ml -+/otherlibs/labltk/labltk/optionmenu.mli -+/otherlibs/labltk/labltk/pack.ml -+/otherlibs/labltk/labltk/pack.mli -+/otherlibs/labltk/labltk/palette.ml -+/otherlibs/labltk/labltk/palette.mli -+/otherlibs/labltk/labltk/pixmap.ml -+/otherlibs/labltk/labltk/pixmap.mli -+/otherlibs/labltk/labltk/place.ml -+/otherlibs/labltk/labltk/place.mli -+/otherlibs/labltk/labltk/radiobutton.ml -+/otherlibs/labltk/labltk/radiobutton.mli -+/otherlibs/labltk/labltk/scale.ml -+/otherlibs/labltk/labltk/scale.mli -+/otherlibs/labltk/labltk/scrollbar.ml -+/otherlibs/labltk/labltk/scrollbar.mli -+/otherlibs/labltk/labltk/selection.ml -+/otherlibs/labltk/labltk/selection.mli -+/otherlibs/labltk/labltk/text.ml -+/otherlibs/labltk/labltk/text.mli -+/otherlibs/labltk/labltk/tk.ml -+/otherlibs/labltk/labltk/tkvars.ml -+/otherlibs/labltk/labltk/tkvars.mli -+/otherlibs/labltk/labltk/tkwait.ml -+/otherlibs/labltk/labltk/tkwait.mli -+/otherlibs/labltk/labltk/toplevel.ml -+/otherlibs/labltk/labltk/toplevel.mli -+/otherlibs/labltk/labltk/winfo.ml -+/otherlibs/labltk/labltk/winfo.mli -+/otherlibs/labltk/labltk/wm.ml -+/otherlibs/labltk/labltk/wm.mli -+/otherlibs/labltk/lib/labltk -+/otherlibs/labltk/lib/labltktop -+/otherlibs/num/nums.cmxa -+/otherlibs/num/nums.cmxs -+/otherlibs/str/str.cmxa -+/otherlibs/str/str.cmxs -+/otherlibs/systhreads/threads.cmxa -+/otherlibs/threads/marshal.mli -+/otherlibs/threads/pervasives.mli -+/otherlibs/threads/unix.mli -+/otherlibs/unix/unix.cmxa -+/otherlibs/unix/unix.cmxs -+/package-macosx -+/parsing/lexer.ml -+/parsing/linenum.ml -+/parsing/parser.ml -+/parsing/parser.mli -+/parsing/parser.output -+/stdlib/caml -+/stdlib/camlheader -+/stdlib/camlheader_ur -+/stdlib/camlheaderd -+/stdlib/stdlib.cmxa -+/stdlib/stdlib.p.cmxa -+/stdlib/sys.ml -+/tools/cvt_emit -+/tools/cvt_emit.ml -+/tools/dumpobj -+/tools/myocamlbuild_config.ml -+/tools/objinfo -+/tools/objinfo_helper -+/tools/ocamlcp -+/tools/ocamldep -+/tools/ocamldep.opt -+/tools/ocamlmklib -+/tools/ocamlmklib.ml -+/tools/ocamlmklibconfig.ml -+/tools/ocamlmktop -+/tools/ocamloptp -+/tools/ocamlprof -+/tools/opnames.ml -+/tools/read_cmt -+/tools/read_cmt.opt -+/utils/config.ml -+/yacc/ocamlyacc -+/yacc/version.h --- -1.8.3.1 - diff --git a/SOURCES/0001-Changes-clarify-compatibility-breaking-change-items.patch b/SOURCES/0001-Changes-clarify-compatibility-breaking-change-items.patch new file mode 100644 index 0000000..a0f93d3 --- /dev/null +++ b/SOURCES/0001-Changes-clarify-compatibility-breaking-change-items.patch @@ -0,0 +1,36 @@ +From 5bd96201dbd70c387c5af4b510d0de4abc0cfd7d Mon Sep 17 00:00:00 2001 +From: Gabriel Scherer +Date: Wed, 12 Jul 2017 11:57:22 -0400 +Subject: [PATCH 01/12] Changes: clarify compatibility-breaking change items + +--- + Changes | 6 ++++++ + 1 file changed, 6 insertions(+) + +diff --git a/Changes b/Changes +index cc59f635e..10642f19d 100644 +--- a/Changes ++++ b/Changes +@@ -64,6 +64,9 @@ OCaml 4.05.0 (13 Jul 2017): + + * MPR#7414, GPR#929: Soundness bug with non-generalized type variables and + functors. ++ (compatibility: some code using module-global mutable state will ++ fail at compile-time and is fixed by adding extra annotations; ++ see the Mantis and Github discussions.) + (Jacques Garrigue, report by Leo White) + + ### Compiler user-interface and warnings: +@@ -567,6 +570,9 @@ The complete list of changes is listed below. + (Mark Shinwell, Leo White, review by Xavier Leroy) + + * GPR#1088: Gc.minor_words now returns accurate numbers. ++ (compatibility: the .mli declaration of `Gc.minor_words` ++ and `Gc.get_minor_free` changed, which may break libraries ++ re-exporting these values.) + (Stephen Dolan, review by Pierre Chambart and Xavier Leroy) + + OCaml 4.04.2 (23 Jun 2017): +-- +2.13.2 + diff --git a/SOURCES/0002-Ensure-empty-compilerlibs-directory-is-created-by-gi.patch b/SOURCES/0002-Ensure-empty-compilerlibs-directory-is-created-by-gi.patch deleted file mode 100644 index 51dd662..0000000 --- a/SOURCES/0002-Ensure-empty-compilerlibs-directory-is-created-by-gi.patch +++ /dev/null @@ -1,18 +0,0 @@ -From a0c1f4805f85cc3ba4217ecbcae62cd567eb9dab Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Thu, 7 Jun 2012 15:36:16 +0100 -Subject: [PATCH 02/19] Ensure empty compilerlibs/ directory is created by git. - -This directory exists in the OCaml tarball, but is empty. As a -result, git ignores it unless we put a dummy file in it. ---- - compilerlibs/.exists | 0 - 1 file changed, 0 insertions(+), 0 deletions(-) - create mode 100644 compilerlibs/.exists - -diff --git a/compilerlibs/.exists b/compilerlibs/.exists -new file mode 100644 -index 0000000..e69de29 --- -1.8.3.1 - diff --git a/SOURCES/0002-MPR-7591-frametable-not-8-aligned-on-x86-64-port.patch b/SOURCES/0002-MPR-7591-frametable-not-8-aligned-on-x86-64-port.patch new file mode 100644 index 0000000..0fa4fda --- /dev/null +++ b/SOURCES/0002-MPR-7591-frametable-not-8-aligned-on-x86-64-port.patch @@ -0,0 +1,44 @@ +From 22dbcdfb921b19d171134de90984805622877e55 Mon Sep 17 00:00:00 2001 +From: Xavier Leroy +Date: Sat, 22 Jul 2017 16:32:23 -0400 +Subject: [PATCH 02/12] MPR#7591: frametable not 8-aligned on x86-64 port + +Cherry-pick of 7077b60 from trunk. +--- + Changes | 7 +++++++ + asmcomp/amd64/emit.mlp | 3 ++- + 2 files changed, 9 insertions(+), 1 deletion(-) + +diff --git a/Changes b/Changes +index 10642f19d..cc7e0a82f 100644 +--- a/Changes ++++ b/Changes +@@ -1,3 +1,10 @@ ++Working 4.05.x branch ++--------------------- ++ ++- MPR#7591, GPR#1257: on x86-64, frame table is not 8-aligned ++ (Xavier Leroy, report by Mantis user "voglerr", review by Gabriel Scherer) ++ ++ + OCaml 4.05.0 (13 Jul 2017): + --------------------------- + +diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp +index c3f8692a8..75a785f74 100644 +--- a/asmcomp/amd64/emit.mlp ++++ b/asmcomp/amd64/emit.mlp +@@ -1065,8 +1065,9 @@ let end_assembly() = + + D.data (); + emit_global_label "data_end"; +- D.long (const 0); ++ D.qword (const 0); + ++ D.align 8; (* PR#7591 *) + emit_global_label "frametable"; + + let setcnt = ref 0 in +-- +2.13.2 + diff --git a/SOURCES/0003-Fixes-for-out-of-range-Ialloc.patch b/SOURCES/0003-Fixes-for-out-of-range-Ialloc.patch new file mode 100644 index 0000000..2cba417 --- /dev/null +++ b/SOURCES/0003-Fixes-for-out-of-range-Ialloc.patch @@ -0,0 +1,409 @@ +From 664f0763d37f85e2ec53d6394251b5948dcfa727 Mon Sep 17 00:00:00 2001 +From: Mark Shinwell +Date: Mon, 31 Jul 2017 14:37:47 +0100 +Subject: [PATCH 03/12] Fixes for out-of-range Ialloc + +Cherry-pick of GPR#1271 which was merged on trunk. + +Fixes for Ialloc instructions allocating more than Max_young_wosize words in the minor heap + +Out-of-range Ialloc instructions cause various problems, see in particular GPR #1250. +--- + Changes | 5 + + asmcomp/cmmgen.ml | 38 ++-- + asmcomp/selectgen.ml | 3 +- + testsuite/tests/basic-more/pr1271.ml | 288 ++++++++++++++++++++++++++++ + testsuite/tests/basic-more/pr1271.reference | 2 + + 5 files changed, 317 insertions(+), 19 deletions(-) + create mode 100644 testsuite/tests/basic-more/pr1271.ml + create mode 100644 testsuite/tests/basic-more/pr1271.reference + +diff --git a/Changes b/Changes +index cc7e0a82f..e8dbd42e2 100644 +--- a/Changes ++++ b/Changes +@@ -4,6 +4,11 @@ Working 4.05.x branch + - MPR#7591, GPR#1257: on x86-64, frame table is not 8-aligned + (Xavier Leroy, report by Mantis user "voglerr", review by Gabriel Scherer) + ++- GPR#1271: Don't generate Ialloc instructions for closures that exceed ++ Max_young_wosize; instead allocate them on the major heap. (Related ++ to GPR#1250.) ++ (Mark Shinwell) ++ + + OCaml 4.05.0 (13 Jul 2017): + --------------------------- +diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml +index 4ac4b40c6..2120d3985 100644 +--- a/asmcomp/cmmgen.ml ++++ b/asmcomp/cmmgen.ml +@@ -1641,29 +1641,31 @@ let rec transl env e = + List.iter (fun f -> Queue.add f functions) fundecls; + Cconst_symbol lbl + | Uclosure(fundecls, clos_vars) -> +- let block_size = +- fundecls_size fundecls + List.length clos_vars in + let rec transl_fundecls pos = function + [] -> + List.map (transl env) clos_vars + | f :: rem -> + Queue.add f functions; +- let header = +- if pos = 0 +- then alloc_closure_header block_size f.dbg +- else alloc_infix_header pos f.dbg in +- if f.arity = 1 || f.arity = 0 then +- header :: +- Cconst_symbol f.label :: +- int_const f.arity :: +- transl_fundecls (pos + 3) rem +- else +- header :: +- Cconst_symbol(curry_function f.arity) :: +- int_const f.arity :: +- Cconst_symbol f.label :: +- transl_fundecls (pos + 4) rem in +- Cop(Calloc, transl_fundecls 0 fundecls, Debuginfo.none) ++ let without_header = ++ if f.arity = 1 || f.arity = 0 then ++ Cconst_symbol f.label :: ++ int_const f.arity :: ++ transl_fundecls (pos + 3) rem ++ else ++ Cconst_symbol(curry_function f.arity) :: ++ int_const f.arity :: ++ Cconst_symbol f.label :: ++ transl_fundecls (pos + 4) rem ++ in ++ if pos = 0 then without_header ++ else (alloc_infix_header pos f.dbg) :: without_header ++ in ++ let dbg = ++ match fundecls with ++ | [] -> Debuginfo.none ++ | fundecl::_ -> fundecl.dbg ++ in ++ make_alloc dbg Obj.closure_tag (transl_fundecls 0 fundecls) + | Uoffset(arg, offset) -> + (* produces a valid Caml value, pointing just after an infix header *) + let ptr = transl env arg in +diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml +index 7cd8cd5c3..1158fc0d0 100644 +--- a/asmcomp/selectgen.ml ++++ b/asmcomp/selectgen.ml +@@ -738,7 +738,8 @@ method emit_expr (env:environment) exp = + loc_arg (Proc.loc_external_results rd) in + self#insert_move_results loc_res rd stack_ofs; + Some rd +- | Ialloc { words = _; spacetime_index; label_after_call_gc; } -> ++ | Ialloc { words; spacetime_index; label_after_call_gc; } -> ++ assert (words <= Config.max_young_wosize); + let rd = self#regs_for typ_val in + let size = size_expr env (Ctuple new_args) in + let op = +diff --git a/testsuite/tests/basic-more/pr1271.ml b/testsuite/tests/basic-more/pr1271.ml +new file mode 100644 +index 000000000..3890d0fbb +--- /dev/null ++++ b/testsuite/tests/basic-more/pr1271.ml +@@ -0,0 +1,288 @@ ++(* GPR#1271 *) ++ ++module F (X : sig val x : int end) = struct ++ let rec f1 y = f270 (X.x + y) ++ and f2 y = (f1 [@inlined never]) y ++ and f3 y = (f2 [@inlined never]) y ++ and f4 y = (f3 [@inlined never]) y ++ and f5 y = (f4 [@inlined never]) y ++ and f6 y = (f5 [@inlined never]) y ++ and f7 y = (f6 [@inlined never]) y ++ and f8 y = (f7 [@inlined never]) y ++ and f9 y = (f8 [@inlined never]) y ++ and f10 y = (f9 [@inlined never]) y ++ and f11 y = (f10 [@inlined never]) y ++ and f12 y = (f11 [@inlined never]) y ++ and f13 y = (f12 [@inlined never]) y ++ and f14 y = (f13 [@inlined never]) y ++ and f15 y = (f14 [@inlined never]) y ++ and f16 y = (f15 [@inlined never]) y ++ and f17 y = (f16 [@inlined never]) y ++ and f18 y = (f17 [@inlined never]) y ++ and f19 y = (f18 [@inlined never]) y ++ and f20 y = (f19 [@inlined never]) y ++ and f21 y = (f20 [@inlined never]) y ++ and f22 y = (f21 [@inlined never]) y ++ and f23 y = (f22 [@inlined never]) y ++ and f24 y = (f23 [@inlined never]) y ++ and f25 y = (f24 [@inlined never]) y ++ and f26 y = (f25 [@inlined never]) y ++ and f27 y = (f26 [@inlined never]) y ++ and f28 y = (f27 [@inlined never]) y ++ and f29 y = (f28 [@inlined never]) y ++ and f30 y = (f29 [@inlined never]) y ++ and f31 y = (f30 [@inlined never]) y ++ and f32 y = (f31 [@inlined never]) y ++ and f33 y = (f32 [@inlined never]) y ++ and f34 y = (f33 [@inlined never]) y ++ and f35 y = (f34 [@inlined never]) y ++ and f36 y = (f35 [@inlined never]) y ++ and f37 y = (f36 [@inlined never]) y ++ and f38 y = (f37 [@inlined never]) y ++ and f39 y = (f38 [@inlined never]) y ++ and f40 y = (f39 [@inlined never]) y ++ and f41 y = (f40 [@inlined never]) y ++ and f42 y = (f41 [@inlined never]) y ++ and f43 y = (f42 [@inlined never]) y ++ and f44 y = (f43 [@inlined never]) y ++ and f45 y = (f44 [@inlined never]) y ++ and f46 y = (f45 [@inlined never]) y ++ and f47 y = (f46 [@inlined never]) y ++ and f48 y = (f47 [@inlined never]) y ++ and f49 y = (f48 [@inlined never]) y ++ and f50 y = (f49 [@inlined never]) y ++ and f51 y = (f50 [@inlined never]) y ++ and f52 y = (f51 [@inlined never]) y ++ and f53 y = (f52 [@inlined never]) y ++ and f54 y = (f53 [@inlined never]) y ++ and f55 y = (f54 [@inlined never]) y ++ and f56 y = (f55 [@inlined never]) y ++ and f57 y = (f56 [@inlined never]) y ++ and f58 y = (f57 [@inlined never]) y ++ and f59 y = (f58 [@inlined never]) y ++ and f60 y = (f59 [@inlined never]) y ++ and f61 y = (f60 [@inlined never]) y ++ and f62 y = (f61 [@inlined never]) y ++ and f63 y = (f62 [@inlined never]) y ++ and f64 y = (f63 [@inlined never]) y ++ and f65 y = (f64 [@inlined never]) y ++ and f66 y = (f65 [@inlined never]) y ++ and f67 y = (f66 [@inlined never]) y ++ and f68 y = (f67 [@inlined never]) y ++ and f69 y = (f68 [@inlined never]) y ++ and f70 y = (f69 [@inlined never]) y ++ and f71 y = (f70 [@inlined never]) y ++ and f72 y = (f71 [@inlined never]) y ++ and f73 y = (f72 [@inlined never]) y ++ and f74 y = (f73 [@inlined never]) y ++ and f75 y = (f74 [@inlined never]) y ++ and f76 y = (f75 [@inlined never]) y ++ and f77 y = (f76 [@inlined never]) y ++ and f78 y = (f77 [@inlined never]) y ++ and f79 y = (f78 [@inlined never]) y ++ and f80 y = (f79 [@inlined never]) y ++ and f81 y = (f80 [@inlined never]) y ++ and f82 y = (f81 [@inlined never]) y ++ and f83 y = (f82 [@inlined never]) y ++ and f84 y = (f83 [@inlined never]) y ++ and f85 y = (f84 [@inlined never]) y ++ and f86 y = (f85 [@inlined never]) y ++ and f87 y = (f86 [@inlined never]) y ++ and f88 y = (f87 [@inlined never]) y ++ and f89 y = (f88 [@inlined never]) y ++ and f90 y = (f89 [@inlined never]) y ++ and f91 y = (f90 [@inlined never]) y ++ and f92 y = (f91 [@inlined never]) y ++ and f93 y = (f92 [@inlined never]) y ++ and f94 y = (f93 [@inlined never]) y ++ and f95 y = (f94 [@inlined never]) y ++ and f96 y = (f95 [@inlined never]) y ++ and f97 y = (f96 [@inlined never]) y ++ and f98 y = (f97 [@inlined never]) y ++ and f99 y = (f98 [@inlined never]) y ++ and f100 y = (f99 [@inlined never]) y ++ and f101 y = (f100 [@inlined never]) y ++ and f102 y = (f101 [@inlined never]) y ++ and f103 y = (f102 [@inlined never]) y ++ and f104 y = (f103 [@inlined never]) y ++ and f105 y = (f104 [@inlined never]) y ++ and f106 y = (f105 [@inlined never]) y ++ and f107 y = (f106 [@inlined never]) y ++ and f108 y = (f107 [@inlined never]) y ++ and f109 y = (f108 [@inlined never]) y ++ and f110 y = (f109 [@inlined never]) y ++ and f111 y = (f110 [@inlined never]) y ++ and f112 y = (f111 [@inlined never]) y ++ and f113 y = (f112 [@inlined never]) y ++ and f114 y = (f113 [@inlined never]) y ++ and f115 y = (f114 [@inlined never]) y ++ and f116 y = (f115 [@inlined never]) y ++ and f117 y = (f116 [@inlined never]) y ++ and f118 y = (f117 [@inlined never]) y ++ and f119 y = (f118 [@inlined never]) y ++ and f120 y = (f119 [@inlined never]) y ++ and f121 y = (f120 [@inlined never]) y ++ and f122 y = (f121 [@inlined never]) y ++ and f123 y = (f122 [@inlined never]) y ++ and f124 y = (f123 [@inlined never]) y ++ and f125 y = (f124 [@inlined never]) y ++ and f126 y = (f125 [@inlined never]) y ++ and f127 y = (f126 [@inlined never]) y ++ and f128 y = (f127 [@inlined never]) y ++ and f129 y = (f128 [@inlined never]) y ++ and f130 y = (f129 [@inlined never]) y ++ and f131 y = (f130 [@inlined never]) y ++ and f132 y = (f131 [@inlined never]) y ++ and f133 y = (f132 [@inlined never]) y ++ and f134 y = (f133 [@inlined never]) y ++ and f135 y = (f134 [@inlined never]) y ++ and f136 y = (f135 [@inlined never]) y ++ and f137 y = (f136 [@inlined never]) y ++ and f138 y = (f137 [@inlined never]) y ++ and f139 y = (f138 [@inlined never]) y ++ and f140 y = (f139 [@inlined never]) y ++ and f141 y = (f140 [@inlined never]) y ++ and f142 y = (f141 [@inlined never]) y ++ and f143 y = (f142 [@inlined never]) y ++ and f144 y = (f143 [@inlined never]) y ++ and f145 y = (f144 [@inlined never]) y ++ and f146 y = (f145 [@inlined never]) y ++ and f147 y = (f146 [@inlined never]) y ++ and f148 y = (f147 [@inlined never]) y ++ and f149 y = (f148 [@inlined never]) y ++ and f150 y = (f149 [@inlined never]) y ++ and f151 y = (f150 [@inlined never]) y ++ and f152 y = (f151 [@inlined never]) y ++ and f153 y = (f152 [@inlined never]) y ++ and f154 y = (f153 [@inlined never]) y ++ and f155 y = (f154 [@inlined never]) y ++ and f156 y = (f155 [@inlined never]) y ++ and f157 y = (f156 [@inlined never]) y ++ and f158 y = (f157 [@inlined never]) y ++ and f159 y = (f158 [@inlined never]) y ++ and f160 y = (f159 [@inlined never]) y ++ and f161 y = (f160 [@inlined never]) y ++ and f162 y = (f161 [@inlined never]) y ++ and f163 y = (f162 [@inlined never]) y ++ and f164 y = (f163 [@inlined never]) y ++ and f165 y = (f164 [@inlined never]) y ++ and f166 y = (f165 [@inlined never]) y ++ and f167 y = (f166 [@inlined never]) y ++ and f168 y = (f167 [@inlined never]) y ++ and f169 y = (f168 [@inlined never]) y ++ and f170 y = (f169 [@inlined never]) y ++ and f171 y = (f170 [@inlined never]) y ++ and f172 y = (f171 [@inlined never]) y ++ and f173 y = (f172 [@inlined never]) y ++ and f174 y = (f173 [@inlined never]) y ++ and f175 y = (f174 [@inlined never]) y ++ and f176 y = (f175 [@inlined never]) y ++ and f177 y = (f176 [@inlined never]) y ++ and f178 y = (f177 [@inlined never]) y ++ and f179 y = (f178 [@inlined never]) y ++ and f180 y = (f179 [@inlined never]) y ++ and f181 y = (f180 [@inlined never]) y ++ and f182 y = (f181 [@inlined never]) y ++ and f183 y = (f182 [@inlined never]) y ++ and f184 y = (f183 [@inlined never]) y ++ and f185 y = (f184 [@inlined never]) y ++ and f186 y = (f185 [@inlined never]) y ++ and f187 y = (f186 [@inlined never]) y ++ and f188 y = (f187 [@inlined never]) y ++ and f189 y = (f188 [@inlined never]) y ++ and f190 y = (f189 [@inlined never]) y ++ and f191 y = (f190 [@inlined never]) y ++ and f192 y = (f191 [@inlined never]) y ++ and f193 y = (f192 [@inlined never]) y ++ and f194 y = (f193 [@inlined never]) y ++ and f195 y = (f194 [@inlined never]) y ++ and f196 y = (f195 [@inlined never]) y ++ and f197 y = (f196 [@inlined never]) y ++ and f198 y = (f197 [@inlined never]) y ++ and f199 y = (f198 [@inlined never]) y ++ and f200 y = (f199 [@inlined never]) y ++ and f201 y = (f200 [@inlined never]) y ++ and f202 y = (f201 [@inlined never]) y ++ and f203 y = (f202 [@inlined never]) y ++ and f204 y = (f203 [@inlined never]) y ++ and f205 y = (f204 [@inlined never]) y ++ and f206 y = (f205 [@inlined never]) y ++ and f207 y = (f206 [@inlined never]) y ++ and f208 y = (f207 [@inlined never]) y ++ and f209 y = (f208 [@inlined never]) y ++ and f210 y = (f209 [@inlined never]) y ++ and f211 y = (f210 [@inlined never]) y ++ and f212 y = (f211 [@inlined never]) y ++ and f213 y = (f212 [@inlined never]) y ++ and f214 y = (f213 [@inlined never]) y ++ and f215 y = (f214 [@inlined never]) y ++ and f216 y = (f215 [@inlined never]) y ++ and f217 y = (f216 [@inlined never]) y ++ and f218 y = (f217 [@inlined never]) y ++ and f219 y = (f218 [@inlined never]) y ++ and f220 y = (f219 [@inlined never]) y ++ and f221 y = (f220 [@inlined never]) y ++ and f222 y = (f221 [@inlined never]) y ++ and f223 y = (f222 [@inlined never]) y ++ and f224 y = (f223 [@inlined never]) y ++ and f225 y = (f224 [@inlined never]) y ++ and f226 y = (f225 [@inlined never]) y ++ and f227 y = (f226 [@inlined never]) y ++ and f228 y = (f227 [@inlined never]) y ++ and f229 y = (f228 [@inlined never]) y ++ and f230 y = (f229 [@inlined never]) y ++ and f231 y = (f230 [@inlined never]) y ++ and f232 y = (f231 [@inlined never]) y ++ and f233 y = (f232 [@inlined never]) y ++ and f234 y = (f233 [@inlined never]) y ++ and f235 y = (f234 [@inlined never]) y ++ and f236 y = (f235 [@inlined never]) y ++ and f237 y = (f236 [@inlined never]) y ++ and f238 y = (f237 [@inlined never]) y ++ and f239 y = (f238 [@inlined never]) y ++ and f240 y = (f239 [@inlined never]) y ++ and f241 y = (f240 [@inlined never]) y ++ and f242 y = (f241 [@inlined never]) y ++ and f243 y = (f242 [@inlined never]) y ++ and f244 y = (f243 [@inlined never]) y ++ and f245 y = (f244 [@inlined never]) y ++ and f246 y = (f245 [@inlined never]) y ++ and f247 y = (f246 [@inlined never]) y ++ and f248 y = (f247 [@inlined never]) y ++ and f249 y = (f248 [@inlined never]) y ++ and f250 y = (f249 [@inlined never]) y ++ and f251 y = (f250 [@inlined never]) y ++ and f252 y = (f251 [@inlined never]) y ++ and f253 y = (f252 [@inlined never]) y ++ and f254 y = (f253 [@inlined never]) y ++ and f255 y = (f254 [@inlined never]) y ++ and f256 y = (f255 [@inlined never]) y ++ and f257 y = (f256 [@inlined never]) y ++ and f258 y = (f257 [@inlined never]) y ++ and f259 y = (f258 [@inlined never]) y ++ and f260 y = (f259 [@inlined never]) y ++ and f261 y = (f260 [@inlined never]) y ++ and f262 y = (f261 [@inlined never]) y ++ and f263 y = (f262 [@inlined never]) y ++ and f264 y = (f263 [@inlined never]) y ++ and f265 y = (f264 [@inlined never]) y ++ and f266 y = (f265 [@inlined never]) y ++ and f267 y = (f266 [@inlined never]) y ++ and f268 y = (f267 [@inlined never]) y ++ and f269 y = (f268 [@inlined never]) y ++ and f270 y = (f269 [@inlined never]) y ++end ++ ++let words0 = Gc.minor_words () ++let words1 = Gc.minor_words () ++module X = F (struct let x = 42 end) ++let words2 = Gc.minor_words () ++ ++let expected = words1 -. words0 ++ ++let () = ++ match Sys.backend_type with ++ | Sys.Native -> ++ Printf.printf "%.0f" ((words2 -. words1) -. expected) ++ | Sys.Bytecode | Sys.Other _ -> ++ print_string "0" +diff --git a/testsuite/tests/basic-more/pr1271.reference b/testsuite/tests/basic-more/pr1271.reference +new file mode 100644 +index 000000000..6e374c16e +--- /dev/null ++++ b/testsuite/tests/basic-more/pr1271.reference +@@ -0,0 +1,2 @@ ++0 ++All tests succeeded. +-- +2.13.2 + diff --git a/SOURCES/0003-ocamlbyteinfo-ocamlplugininfo-Useful-utilities-from-.patch b/SOURCES/0003-ocamlbyteinfo-ocamlplugininfo-Useful-utilities-from-.patch deleted file mode 100644 index 4c6ef39..0000000 --- a/SOURCES/0003-ocamlbyteinfo-ocamlplugininfo-Useful-utilities-from-.patch +++ /dev/null @@ -1,240 +0,0 @@ -From 4a5da8081ca854cebb0d431d12fc8edcfd3de59a Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Tue, 29 May 2012 20:40:36 +0100 -Subject: [PATCH 03/19] ocamlbyteinfo, ocamlplugininfo: Useful utilities from - Debian, sent upstream. - -See: -http://git.debian.org/?p=pkg-ocaml-maint/packages/ocaml.git;a=tree;f=debian/ocamlbyteinfo;hb=HEAD ---- - ocamlbyteinfo.ml | 101 +++++++++++++++++++++++++++++++++++++++++++++++++ - ocamlplugininfo.ml | 109 +++++++++++++++++++++++++++++++++++++++++++++++++++++ - 2 files changed, 210 insertions(+) - create mode 100644 ocamlbyteinfo.ml - create mode 100644 ocamlplugininfo.ml - -diff --git a/ocamlbyteinfo.ml b/ocamlbyteinfo.ml -new file mode 100644 -index 0000000..eb9a293 ---- /dev/null -+++ b/ocamlbyteinfo.ml -@@ -0,0 +1,101 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -+(* *) -+(* Copyright 2009 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the GNU Library General Public License, with *) -+(* the special exception on linking described in file ../../LICENSE. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id$ *) -+ -+(* Dumps a bytecode binary file *) -+ -+open Sys -+open Dynlinkaux -+ -+let input_stringlist ic len = -+ let get_string_list sect len = -+ let rec fold s e acc = -+ if e != len then -+ if sect.[e] = '\000' then -+ fold (e+1) (e+1) (String.sub sect s (e-s) :: acc) -+ else fold s (e+1) acc -+ else acc -+ in fold 0 0 [] -+ in -+ let sect = String.create len in -+ let _ = really_input ic sect 0 len in -+ get_string_list sect len -+ -+let print = Printf.printf -+let perr s = -+ Printf.eprintf "%s\n" s; -+ exit(1) -+let p_title title = print "%s:\n" title -+ -+let p_section title format pdata = function -+ | [] -> () -+ | l -> -+ p_title title; -+ List.iter -+ (fun (name, data) -> print format (pdata data) name) -+ l -+ -+let p_list title format = function -+ | [] -> () -+ | l -> -+ p_title title; -+ List.iter -+ (fun name -> print format name) -+ l -+ -+let _ = -+ try -+ let input_name = Sys.argv.(1) in -+ let ic = open_in_bin input_name in -+ Bytesections.read_toc ic; -+ List.iter -+ (fun section -> -+ try -+ let len = Bytesections.seek_section ic section in -+ if len > 0 then match section with -+ | "CRCS" -> -+ p_section -+ "Imported Units" -+ "\t%s\t%s\n" -+ Digest.to_hex -+ (input_value ic : (string * Digest.t) list) -+ | "DLLS" -> -+ p_list -+ "Used Dlls" "\t%s\n" -+ (input_stringlist ic len) -+ | "DLPT" -> -+ p_list -+ "Additional Dll paths" -+ "\t%s\n" -+ (input_stringlist ic len) -+ | "PRIM" -> -+ let prims = (input_stringlist ic len) in -+ print "Uses unsafe features: "; -+ begin match prims with -+ [] -> print "no\n" -+ | l -> print "YES\n"; -+ p_list "Primitives declared in this module" -+ "\t%s\n" -+ l -+ end -+ | _ -> () -+ with Not_found | Failure _ | Invalid_argument _ -> () -+ ) -+ ["CRCS"; "DLLS"; "DLPT"; "PRIM"]; -+ close_in ic -+ with -+ | Sys_error msg -> -+ perr msg -+ | Invalid_argument("index out of bounds") -> -+ perr (Printf.sprintf "Usage: %s filename" Sys.argv.(0)) -diff --git a/ocamlplugininfo.ml b/ocamlplugininfo.ml -new file mode 100644 -index 0000000..e28800f ---- /dev/null -+++ b/ocamlplugininfo.ml -@@ -0,0 +1,109 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -+(* *) -+(* Copyright 2009 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the GNU Library General Public License, with *) -+(* the special exception on linking described in file ../../LICENSE. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id$ *) -+ -+(* Dumps a .cmxs file *) -+ -+open Natdynlink -+open Format -+ -+let file = -+ try -+ Sys.argv.(1) -+ with _ -> begin -+ Printf.eprintf "Usage: %s file.cmxs\n" Sys.argv.(0); -+ exit(1) -+ end -+ -+exception Abnormal_exit -+ -+let error s e = -+ let eprint = Printf.eprintf in -+ let print_exc s = function -+ | End_of_file -> -+ eprint "%s: %s\n" s file -+ | Abnormal_exit -> -+ eprint "%s\n" s -+ | e -> eprint "%s\n" (Printexc.to_string e) -+ in -+ print_exc s e; -+ exit(1) -+ -+let read_in command = -+ let cmd = Printf.sprintf command file in -+ let ic = Unix.open_process_in cmd in -+ try -+ let line = input_line ic in -+ begin match (Unix.close_process_in ic) with -+ | Unix.WEXITED 0 -> Str.split (Str.regexp "[ ]+") line -+ | Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> -+ error -+ (Printf.sprintf -+ "Command \"%s\" exited abnormally" -+ cmd -+ ) -+ Abnormal_exit -+ end -+ with e -> error "File is empty" e -+ -+let get_offset adr_off adr_sec = -+ try -+ let adr = List.nth adr_off 4 in -+ let off = List.nth adr_off 5 in -+ let sec = List.hd adr_sec in -+ -+ let (!) x = Int64.of_string ("0x" ^ x) in -+ let (+) = Int64.add in -+ let (-) = Int64.sub in -+ -+ Int64.to_int (!off + !sec - !adr) -+ -+ with Failure _ | Invalid_argument _ -> -+ error -+ "Command output doesn't have the expected format" -+ Abnormal_exit -+ -+let print_infos name crc defines cmi cmx = -+ let print_name_crc (name, crc) = -+ printf "@ %s (%s)" name (Digest.to_hex crc) -+ in -+ let pr_imports ppf imps = List.iter print_name_crc imps in -+ printf "Name: %s@." name; -+ printf "CRC of implementation: %s@." (Digest.to_hex crc); -+ printf "@[Globals defined:"; -+ List.iter (fun s -> printf "@ %s" s) defines; -+ printf "@]@."; -+ printf "@[Interfaces imported:%a@]@." pr_imports cmi; -+ printf "@[Implementations imported:%a@]@." pr_imports cmx -+ -+let _ = -+ let adr_off = read_in "objdump -h %s | grep ' .data '" in -+ let adr_sec = read_in "objdump -T %s | grep ' caml_plugin_header$'" in -+ -+ let ic = open_in file in -+ let _ = seek_in ic (get_offset adr_off adr_sec) in -+ let header = (input_value ic : Natdynlink.dynheader) in -+ if header.magic <> Natdynlink.dyn_magic_number then -+ raise(Error(Natdynlink.Not_a_bytecode_file file)) -+ else begin -+ List.iter -+ (fun ui -> -+ print_infos -+ ui.name -+ ui.crc -+ ui.defines -+ ui.imports_cmi -+ ui.imports_cmx) -+ header.units -+ end --- -1.8.3.1 - diff --git a/SOURCES/0004-Don-t-add-rpaths-to-libraries.patch b/SOURCES/0004-Don-t-add-rpaths-to-libraries.patch index f5641e2..6ce11dc 100644 --- a/SOURCES/0004-Don-t-add-rpaths-to-libraries.patch +++ b/SOURCES/0004-Don-t-add-rpaths-to-libraries.patch @@ -1,20 +1,20 @@ -From 67f9cad7f4d3db0efcbcdf8bb97a2db3757ff14f Mon Sep 17 00:00:00 2001 +From b2118848e9a0aa96c5ccb3ede65f2d0e9cfb114a Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 24 Jun 2014 10:00:15 +0100 -Subject: [PATCH 04/19] Don't add rpaths to libraries. +Subject: [PATCH 04/12] Don't add rpaths to libraries. --- - tools/Makefile.shared | 6 +++--- + tools/Makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) -diff --git a/tools/Makefile.shared b/tools/Makefile.shared -index cf2f216..2d466cd 100644 ---- a/tools/Makefile.shared -+++ b/tools/Makefile.shared -@@ -108,9 +108,9 @@ ocamlmklibconfig.ml: ../config/Makefile - echo 'let ext_dll = "$(EXT_DLL)"'; \ +diff --git a/tools/Makefile b/tools/Makefile +index 9a8cf652b..269aa18e6 100644 +--- a/tools/Makefile ++++ b/tools/Makefile +@@ -156,9 +156,9 @@ $(call byte_and_opt,ocamlmklib,ocamlmklibconfig.cmo config.cmo misc.cmo \ + ocamlmklibconfig.ml: ../config/Makefile Makefile + (echo 'let bindir = "$(BINDIR)"'; \ echo 'let supports_shared_libraries = $(SUPPORTS_SHARED_LIBRARIES)';\ - echo 'let mkdll = "$(MKDLL)"'; \ - echo 'let byteccrpath = "$(BYTECCRPATH)"'; \ - echo 'let nativeccrpath = "$(NATIVECCRPATH)"'; \ - echo 'let mksharedlibrpath = "$(MKSHAREDLIBRPATH)"'; \ @@ -25,5 +25,5 @@ index cf2f216..2d466cd 100644 sed -n -e 's/^#ml //p' ../config/Makefile) \ > ocamlmklibconfig.ml -- -1.8.3.1 +2.13.2 diff --git a/SOURCES/0005-configure-Allow-user-defined-C-compiler-flags.patch b/SOURCES/0005-configure-Allow-user-defined-C-compiler-flags.patch deleted file mode 100644 index 0a5281f..0000000 --- a/SOURCES/0005-configure-Allow-user-defined-C-compiler-flags.patch +++ /dev/null @@ -1,27 +0,0 @@ -From 5c7b50033ad64f20c3cce71adb9b5c93dfa62678 Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Tue, 29 May 2012 20:44:18 +0100 -Subject: [PATCH 05/19] configure: Allow user defined C compiler flags. - ---- - configure | 4 ++++ - 1 file changed, 4 insertions(+) - -diff --git a/configure b/configure -index cbaa053..e8f8cfd 100755 ---- a/configure -+++ b/configure -@@ -1617,6 +1617,10 @@ case "$buggycc" in - nativecccompopts="$nativecccompopts -fomit-frame-pointer";; - esac - -+# Allow user defined C Compiler flags -+bytecccompopts="$bytecccompopts $CFLAGS" -+nativecccompopts="$nativecccompopts $CFLAGS" -+ - # Finish generated files - - cclibs="$cclibs $mathlib" --- -1.8.3.1 - diff --git a/SOURCES/0005-ocamlbyteinfo-ocamlplugininfo-Useful-utilities-from-.patch b/SOURCES/0005-ocamlbyteinfo-ocamlplugininfo-Useful-utilities-from-.patch new file mode 100644 index 0000000..868db9a --- /dev/null +++ b/SOURCES/0005-ocamlbyteinfo-ocamlplugininfo-Useful-utilities-from-.patch @@ -0,0 +1,240 @@ +From 80e2921e472f66f70575d6e4e6c8ff6f5714e4e4 Mon Sep 17 00:00:00 2001 +From: "Richard W.M. Jones" +Date: Tue, 29 May 2012 20:40:36 +0100 +Subject: [PATCH 05/12] ocamlbyteinfo, ocamlplugininfo: Useful utilities from + Debian, sent upstream. + +See: +http://git.debian.org/?p=pkg-ocaml-maint/packages/ocaml.git;a=tree;f=debian/ocamlbyteinfo;hb=HEAD +--- + ocamlbyteinfo.ml | 101 +++++++++++++++++++++++++++++++++++++++++++++++++ + ocamlplugininfo.ml | 109 +++++++++++++++++++++++++++++++++++++++++++++++++++++ + 2 files changed, 210 insertions(+) + create mode 100644 ocamlbyteinfo.ml + create mode 100644 ocamlplugininfo.ml + +diff --git a/ocamlbyteinfo.ml b/ocamlbyteinfo.ml +new file mode 100644 +index 000000000..eb9a293e3 +--- /dev/null ++++ b/ocamlbyteinfo.ml +@@ -0,0 +1,101 @@ ++(***********************************************************************) ++(* *) ++(* Objective Caml *) ++(* *) ++(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) ++(* *) ++(* Copyright 2009 Institut National de Recherche en Informatique et *) ++(* en Automatique. All rights reserved. This file is distributed *) ++(* under the terms of the GNU Library General Public License, with *) ++(* the special exception on linking described in file ../../LICENSE. *) ++(* *) ++(***********************************************************************) ++ ++(* $Id$ *) ++ ++(* Dumps a bytecode binary file *) ++ ++open Sys ++open Dynlinkaux ++ ++let input_stringlist ic len = ++ let get_string_list sect len = ++ let rec fold s e acc = ++ if e != len then ++ if sect.[e] = '\000' then ++ fold (e+1) (e+1) (String.sub sect s (e-s) :: acc) ++ else fold s (e+1) acc ++ else acc ++ in fold 0 0 [] ++ in ++ let sect = String.create len in ++ let _ = really_input ic sect 0 len in ++ get_string_list sect len ++ ++let print = Printf.printf ++let perr s = ++ Printf.eprintf "%s\n" s; ++ exit(1) ++let p_title title = print "%s:\n" title ++ ++let p_section title format pdata = function ++ | [] -> () ++ | l -> ++ p_title title; ++ List.iter ++ (fun (name, data) -> print format (pdata data) name) ++ l ++ ++let p_list title format = function ++ | [] -> () ++ | l -> ++ p_title title; ++ List.iter ++ (fun name -> print format name) ++ l ++ ++let _ = ++ try ++ let input_name = Sys.argv.(1) in ++ let ic = open_in_bin input_name in ++ Bytesections.read_toc ic; ++ List.iter ++ (fun section -> ++ try ++ let len = Bytesections.seek_section ic section in ++ if len > 0 then match section with ++ | "CRCS" -> ++ p_section ++ "Imported Units" ++ "\t%s\t%s\n" ++ Digest.to_hex ++ (input_value ic : (string * Digest.t) list) ++ | "DLLS" -> ++ p_list ++ "Used Dlls" "\t%s\n" ++ (input_stringlist ic len) ++ | "DLPT" -> ++ p_list ++ "Additional Dll paths" ++ "\t%s\n" ++ (input_stringlist ic len) ++ | "PRIM" -> ++ let prims = (input_stringlist ic len) in ++ print "Uses unsafe features: "; ++ begin match prims with ++ [] -> print "no\n" ++ | l -> print "YES\n"; ++ p_list "Primitives declared in this module" ++ "\t%s\n" ++ l ++ end ++ | _ -> () ++ with Not_found | Failure _ | Invalid_argument _ -> () ++ ) ++ ["CRCS"; "DLLS"; "DLPT"; "PRIM"]; ++ close_in ic ++ with ++ | Sys_error msg -> ++ perr msg ++ | Invalid_argument("index out of bounds") -> ++ perr (Printf.sprintf "Usage: %s filename" Sys.argv.(0)) +diff --git a/ocamlplugininfo.ml b/ocamlplugininfo.ml +new file mode 100644 +index 000000000..e28800f31 +--- /dev/null ++++ b/ocamlplugininfo.ml +@@ -0,0 +1,109 @@ ++(***********************************************************************) ++(* *) ++(* Objective Caml *) ++(* *) ++(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) ++(* *) ++(* Copyright 2009 Institut National de Recherche en Informatique et *) ++(* en Automatique. All rights reserved. This file is distributed *) ++(* under the terms of the GNU Library General Public License, with *) ++(* the special exception on linking described in file ../../LICENSE. *) ++(* *) ++(***********************************************************************) ++ ++(* $Id$ *) ++ ++(* Dumps a .cmxs file *) ++ ++open Natdynlink ++open Format ++ ++let file = ++ try ++ Sys.argv.(1) ++ with _ -> begin ++ Printf.eprintf "Usage: %s file.cmxs\n" Sys.argv.(0); ++ exit(1) ++ end ++ ++exception Abnormal_exit ++ ++let error s e = ++ let eprint = Printf.eprintf in ++ let print_exc s = function ++ | End_of_file -> ++ eprint "%s: %s\n" s file ++ | Abnormal_exit -> ++ eprint "%s\n" s ++ | e -> eprint "%s\n" (Printexc.to_string e) ++ in ++ print_exc s e; ++ exit(1) ++ ++let read_in command = ++ let cmd = Printf.sprintf command file in ++ let ic = Unix.open_process_in cmd in ++ try ++ let line = input_line ic in ++ begin match (Unix.close_process_in ic) with ++ | Unix.WEXITED 0 -> Str.split (Str.regexp "[ ]+") line ++ | Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> ++ error ++ (Printf.sprintf ++ "Command \"%s\" exited abnormally" ++ cmd ++ ) ++ Abnormal_exit ++ end ++ with e -> error "File is empty" e ++ ++let get_offset adr_off adr_sec = ++ try ++ let adr = List.nth adr_off 4 in ++ let off = List.nth adr_off 5 in ++ let sec = List.hd adr_sec in ++ ++ let (!) x = Int64.of_string ("0x" ^ x) in ++ let (+) = Int64.add in ++ let (-) = Int64.sub in ++ ++ Int64.to_int (!off + !sec - !adr) ++ ++ with Failure _ | Invalid_argument _ -> ++ error ++ "Command output doesn't have the expected format" ++ Abnormal_exit ++ ++let print_infos name crc defines cmi cmx = ++ let print_name_crc (name, crc) = ++ printf "@ %s (%s)" name (Digest.to_hex crc) ++ in ++ let pr_imports ppf imps = List.iter print_name_crc imps in ++ printf "Name: %s@." name; ++ printf "CRC of implementation: %s@." (Digest.to_hex crc); ++ printf "@[Globals defined:"; ++ List.iter (fun s -> printf "@ %s" s) defines; ++ printf "@]@."; ++ printf "@[Interfaces imported:%a@]@." pr_imports cmi; ++ printf "@[Implementations imported:%a@]@." pr_imports cmx ++ ++let _ = ++ let adr_off = read_in "objdump -h %s | grep ' .data '" in ++ let adr_sec = read_in "objdump -T %s | grep ' caml_plugin_header$'" in ++ ++ let ic = open_in file in ++ let _ = seek_in ic (get_offset adr_off adr_sec) in ++ let header = (input_value ic : Natdynlink.dynheader) in ++ if header.magic <> Natdynlink.dyn_magic_number then ++ raise(Error(Natdynlink.Not_a_bytecode_file file)) ++ else begin ++ List.iter ++ (fun ui -> ++ print_infos ++ ui.name ++ ui.crc ++ ui.defines ++ ui.imports_cmi ++ ui.imports_cmx) ++ header.units ++ end +-- +2.13.2 + diff --git a/SOURCES/0006-Add-support-for-ppc64.patch b/SOURCES/0006-Add-support-for-ppc64.patch deleted file mode 100644 index 4ee759e..0000000 --- a/SOURCES/0006-Add-support-for-ppc64.patch +++ /dev/null @@ -1,2130 +0,0 @@ -From 959c12d1dfa5a3049fc4c7aed794afa287c46594 Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Tue, 29 May 2012 20:47:07 +0100 -Subject: [PATCH 06/19] Add support for ppc64. - -Note (1): This patch was rejected upstream because they don't have -appropriate hardware for testing. - -Note (2): Upstream powerpc directory has some support for ppc64, but -only for Macs, and I couldn't get it to work at all with IBM hardware. - -This patch was collaborated on by several people, most notably -David Woodhouse. - -Includes fix for position of stack arguments to external C functions -when there are more than 8 parameters (RHBZ#829187). - -Includes fix for minor heap corruption because of unaligned minor heap -register (RHBZ#826649). - -Includes updates for OCaml 4.01.0. ---- - asmcomp/power64/arch.ml | 88 ++++ - asmcomp/power64/emit.mlp | 988 ++++++++++++++++++++++++++++++++++++++++++ - asmcomp/power64/proc.ml | 240 ++++++++++ - asmcomp/power64/reload.ml | 18 + - asmcomp/power64/scheduling.ml | 65 +++ - asmcomp/power64/selection.ml | 101 +++++ - asmrun/Makefile | 6 + - asmrun/power64-elf.S | 486 +++++++++++++++++++++ - asmrun/stack.h | 9 + - configure | 3 + - 10 files changed, 2004 insertions(+) - create mode 100644 asmcomp/power64/arch.ml - create mode 100644 asmcomp/power64/emit.mlp - create mode 100644 asmcomp/power64/proc.ml - create mode 100644 asmcomp/power64/reload.ml - create mode 100644 asmcomp/power64/scheduling.ml - create mode 100644 asmcomp/power64/selection.ml - create mode 100644 asmrun/power64-elf.S - -diff --git a/asmcomp/power64/arch.ml b/asmcomp/power64/arch.ml -new file mode 100644 -index 0000000..73c516d ---- /dev/null -+++ b/asmcomp/power64/arch.ml -@@ -0,0 +1,88 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: arch.ml 9547 2010-01-22 12:48:24Z doligez $ *) -+ -+(* Specific operations for the PowerPC processor *) -+ -+open Format -+ -+(* Machine-specific command-line options *) -+ -+let command_line_options = [] -+ -+(* Specific operations *) -+ -+type specific_operation = -+ Imultaddf (* multiply and add *) -+ | Imultsubf (* multiply and subtract *) -+ | Ialloc_far of int (* allocation in large functions *) -+ -+(* Addressing modes *) -+ -+type addressing_mode = -+ Ibased of string * int (* symbol + displ *) -+ | Iindexed of int (* reg + displ *) -+ | Iindexed2 (* reg + reg *) -+ -+(* Sizes, endianness *) -+ -+let big_endian = true -+ -+let size_addr = 8 -+let size_int = size_addr -+let size_float = 8 -+ -+let allow_unaligned_access = false -+ -+(* Behavior of division *) -+ -+let division_crashes_on_overflow = false -+ -+(* Operations on addressing modes *) -+ -+let identity_addressing = Iindexed 0 -+ -+let offset_addressing addr delta = -+ match addr with -+ Ibased(s, n) -> Ibased(s, n + delta) -+ | Iindexed n -> Iindexed(n + delta) -+ | Iindexed2 -> assert false -+ -+let num_args_addressing = function -+ Ibased(s, n) -> 0 -+ | Iindexed n -> 1 -+ | Iindexed2 -> 2 -+ -+(* Printing operations and addressing modes *) -+ -+let print_addressing printreg addr ppf arg = -+ match addr with -+ | Ibased(s, n) -> -+ let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in -+ fprintf ppf "\"%s\"%s" s idx -+ | Iindexed n -> -+ let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in -+ fprintf ppf "%a%s" printreg arg.(0) idx -+ | Iindexed2 -> -+ fprintf ppf "%a + %a" printreg arg.(0) printreg arg.(1) -+ -+let print_specific_operation printreg op ppf arg = -+ match op with -+ | Imultaddf -> -+ fprintf ppf "%a *f %a +f %a" -+ printreg arg.(0) printreg arg.(1) printreg arg.(2) -+ | Imultsubf -> -+ fprintf ppf "%a *f %a -f %a" -+ printreg arg.(0) printreg arg.(1) printreg arg.(2) -+ | Ialloc_far n -> -+ fprintf ppf "alloc_far %d" n -diff --git a/asmcomp/power64/emit.mlp b/asmcomp/power64/emit.mlp -new file mode 100644 -index 0000000..d84ac5c ---- /dev/null -+++ b/asmcomp/power64/emit.mlp -@@ -0,0 +1,988 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: emit.mlp 9547 2010-01-22 12:48:24Z doligez $ *) -+ -+(* Emission of PowerPC assembly code *) -+ -+module StringSet = Set.Make(struct type t = string let compare = compare end) -+ -+open Misc -+open Cmm -+open Arch -+open Proc -+open Reg -+open Mach -+open Linearize -+open Emitaux -+ -+(* Layout of the stack. The stack is kept 16-aligned. *) -+ -+let stack_size_lbl = ref 0 -+let stack_slot_lbl = ref 0 -+let stack_args_size = ref 0 -+let stack_traps_size = ref 0 -+ -+(* We have a stack frame of our own if we call other functions (including -+ use of exceptions, or if we need more than the red zone *) -+let has_stack_frame () = -+ if !contains_calls || (num_stack_slots.(0) + num_stack_slots.(1)) > (288-16)/8 then -+ true -+ else -+ false -+ -+let frame_size_sans_args () = -+ let size = 8 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 48 in -+ Misc.align size 16 -+ -+let slot_offset loc cls = -+ match loc with -+ Local n -> -+ if cls = 0 -+ then (!stack_slot_lbl, num_stack_slots.(1) * 8 + n * 8) -+ else (!stack_slot_lbl, n * 8) -+ | Incoming n -> ((if has_stack_frame() then !stack_size_lbl else 0), 48 + n) -+ | Outgoing n -> (0, n) -+ -+(* Output a symbol *) -+ -+let emit_symbol = -+ match Config.system with -+ | "elf" | "bsd" -> (fun s -> Emitaux.emit_symbol '.' s) -+ | "rhapsody" -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s) -+ | _ -> assert false -+ -+(* Output a label *) -+ -+let label_prefix = -+ match Config.system with -+ | "elf" | "bsd" -> ".L" -+ | "rhapsody" -> "L" -+ | _ -> assert false -+ -+let emit_label lbl = -+ emit_string label_prefix; emit_int lbl -+ -+(* Section switching *) -+ -+let toc_space = -+ match Config.system with -+ | "elf" | "bsd" -> " .section \".toc\",\"aw\"\n" -+ | "rhapsody" -> " .toc\n" -+ | _ -> assert false -+ -+let data_space = -+ match Config.system with -+ | "elf" | "bsd" -> " .section \".data\"\n" -+ | "rhapsody" -> " .data\n" -+ | _ -> assert false -+ -+let code_space = -+ match Config.system with -+ | "elf" | "bsd" -> " .section \".text\"\n" -+ | "rhapsody" -> " .text\n" -+ | _ -> assert false -+ -+let rodata_space = -+ match Config.system with -+ | "elf" | "bsd" -> " .section \".rodata\"\n" -+ | "rhapsody" -> " .const\n" -+ | _ -> assert false -+ -+(* Output a pseudo-register *) -+ -+let emit_reg r = -+ match r.loc with -+ Reg r -> emit_string (register_name r) -+ | _ -> fatal_error "Emit.emit_reg" -+ -+let use_full_regnames = -+ Config.system = "rhapsody" -+ -+let emit_gpr r = -+ if use_full_regnames then emit_char 'r'; -+ emit_int r -+ -+let emit_fpr r = -+ if use_full_regnames then emit_char 'f'; -+ emit_int r -+ -+let emit_ccr r = -+ if use_full_regnames then emit_string "cr"; -+ emit_int r -+ -+(* Output a stack reference *) -+ -+let emit_stack r = -+ match r.loc with -+ Stack s -> -+ let lbl, ofs = slot_offset s (register_class r) in -+ if lbl > 0 then -+ `{emit_label lbl}+`; -+ `{emit_int ofs}({emit_gpr 1})` -+ | _ -> fatal_error "Emit.emit_stack" -+ -+(* Split a 32-bit integer constants in two 16-bit halves *) -+ -+let low n = n land 0xFFFF -+let high n = n asr 16 -+ -+let nativelow n = Nativeint.to_int n land 0xFFFF -+let nativehigh n = Nativeint.to_int (Nativeint.shift_right n 16) -+ -+let is_immediate n = -+ n <= 32767 && n >= -32768 -+ -+let is_native_immediate n = -+ n <= 32767n && n >= -32768n -+ -+ -+type tocentry = -+ TocSymOfs of (string * int) -+ | TocLabel of int -+ | TocInt of nativeint -+ | TocFloat of string -+ -+(* List of all labels in tocref (reverse order) *) -+let tocref_entries = ref [] -+ -+(* Output a TOC reference *) -+ -+let emit_symbol_offset (s, d) = -+ emit_symbol s; -+ if d > 0 then `+`; -+ if d <> 0 then emit_int d -+ -+let emit_tocentry entry = -+ match entry with -+ TocSymOfs(s,d) -> emit_symbol_offset(s,d) -+ | TocInt i -> emit_nativeint i -+ | TocFloat f -> emit_string f -+ | TocLabel lbl -> emit_label lbl -+ -+ let rec tocref_label = function -+ ( [] , content ) -> -+ let lbl = new_label() in -+ tocref_entries := (lbl, content) :: !tocref_entries; -+ lbl -+ | ( (lbl, o_content) :: lst, content) -> -+ if content = o_content then -+ lbl -+ else -+ tocref_label (lst, content) -+ -+let emit_tocref entry = -+ let lbl = tocref_label (!tocref_entries,entry) in -+ emit_label lbl; emit_string "@toc(2) #"; emit_tocentry entry -+ -+ -+(* Output a load or store operation *) -+ -+let valid_offset instr ofs = -+ ofs land 3 = 0 || (instr <> "ld" && instr <> "std") -+ -+let emit_load_store instr addressing_mode addr n arg = -+ match addressing_mode with -+ Ibased(s, d) -> -+ let dd = (d + 0x8000) in (* We can only offset by -0x8000 .. +0x7fff *) -+ let a = (dd land -0x10000) in -+ let b = (dd land 0xffff) - 0x8000 in -+ ` ld {emit_gpr 11}, {emit_tocref (TocSymOfs (s,a))}\n`; -+ ` {emit_string instr} {emit_reg arg}, {emit_int b}({emit_gpr 11})\n` -+ | Iindexed ofs -> -+ if is_immediate ofs && valid_offset instr ofs then -+ ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n` -+ else begin -+ ` lis {emit_gpr 0}, {emit_int(high ofs)}\n`; -+ if low ofs <> 0 then -+ ` ori {emit_gpr 0}, {emit_gpr 0}, {emit_int(low ofs)}\n`; -+ ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_gpr 0}\n` -+ end -+ | Iindexed2 -> -+ ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n` -+ -+(* After a comparison, extract the result as 0 or 1 *) -+ -+let emit_set_comp cmp res = -+ ` mfcr {emit_gpr 0}\n`; -+ let bitnum = -+ match cmp with -+ Ceq | Cne -> 2 -+ | Cgt | Cle -> 1 -+ | Clt | Cge -> 0 in -+` rlwinm {emit_reg res}, {emit_gpr 0}, {emit_int(bitnum+1)}, 31, 31\n`; -+ begin match cmp with -+ Cne | Cle | Cge -> ` xori {emit_reg res}, {emit_reg res}, 1\n` -+ | _ -> () -+ end -+ -+(* Record live pointers at call points *) -+ -+type frame_descr = -+ { fd_lbl: int; (* Return address *) -+ fd_frame_size_lbl: int; (* Size of stack frame *) -+ fd_live_offset: (int * int) list } (* Offsets/regs of live addresses *) -+ -+let frame_descriptors = ref([] : frame_descr list) -+ -+let record_frame live = -+ let lbl = new_label() in -+ let live_offset = ref [] in -+ Reg.Set.iter -+ (function -+ {typ = Addr; loc = Reg r} -> -+ live_offset := (0, (r lsl 1) + 1) :: !live_offset -+ | {typ = Addr; loc = Stack s} as reg -> -+ live_offset := slot_offset s (register_class reg) :: !live_offset -+ | _ -> ()) -+ live; -+ frame_descriptors := -+ { fd_lbl = lbl; -+ fd_frame_size_lbl = !stack_size_lbl; (* frame_size *) -+ fd_live_offset = !live_offset } :: !frame_descriptors; -+ `{emit_label lbl}:\n` -+ -+let emit_frame fd = -+ ` .quad {emit_label fd.fd_lbl} + 4\n`; -+ ` .short {emit_label fd.fd_frame_size_lbl}\n`; -+ ` .short {emit_int (List.length fd.fd_live_offset)}\n`; -+ List.iter -+ (fun (lbl,n) -> -+ ` .short `; -+ if lbl > 0 then `{emit_label lbl}+`; -+ `{emit_int n}\n`) -+ fd.fd_live_offset; -+ ` .align 3\n` -+ -+(* Record external C functions to be called in a position-independent way -+ (for MacOSX) *) -+ -+let pic_externals = (Config.system = "rhapsody") -+ -+let external_functions = ref StringSet.empty -+ -+let emit_external s = -+ ` .non_lazy_symbol_pointer\n`; -+ `L{emit_symbol s}$non_lazy_ptr:\n`; -+ ` .indirect_symbol {emit_symbol s}\n`; -+ ` .quad 0\n` -+ -+(* Names for conditional branches after comparisons *) -+ -+let branch_for_comparison = function -+ Ceq -> "beq" | Cne -> "bne" -+ | Cle -> "ble" | Cgt -> "bgt" -+ | Cge -> "bge" | Clt -> "blt" -+ -+let name_for_int_comparison = function -+ Isigned cmp -> ("cmpd", branch_for_comparison cmp) -+ | Iunsigned cmp -> ("cmpld", branch_for_comparison cmp) -+ -+(* Names for various instructions *) -+ -+let name_for_intop = function -+ Iadd -> "add" -+ | Imul -> "mulld" -+ | Idiv -> "divd" -+ | Iand -> "and" -+ | Ior -> "or" -+ | Ixor -> "xor" -+ | Ilsl -> "sld" -+ | Ilsr -> "srd" -+ | Iasr -> "srad" -+ | _ -> Misc.fatal_error "Emit.Intop" -+ -+let name_for_intop_imm = function -+ Iadd -> "addi" -+ | Imul -> "mulli" -+ | Iand -> "andi." -+ | Ior -> "ori" -+ | Ixor -> "xori" -+ | Ilsl -> "sldi" -+ | Ilsr -> "srdi" -+ | Iasr -> "sradi" -+ | _ -> Misc.fatal_error "Emit.Intop_imm" -+ -+let name_for_floatop1 = function -+ Inegf -> "fneg" -+ | Iabsf -> "fabs" -+ | _ -> Misc.fatal_error "Emit.Iopf1" -+ -+let name_for_floatop2 = function -+ Iaddf -> "fadd" -+ | Isubf -> "fsub" -+ | Imulf -> "fmul" -+ | Idivf -> "fdiv" -+ | _ -> Misc.fatal_error "Emit.Iopf2" -+ -+let name_for_specific = function -+ Imultaddf -> "fmadd" -+ | Imultsubf -> "fmsub" -+ | _ -> Misc.fatal_error "Emit.Ispecific" -+ -+(* Name of current function *) -+let function_name = ref "" -+(* Entry point for tail recursive calls *) -+let tailrec_entry_point = ref 0 -+(* Names of functions defined in the current file *) -+let defined_functions = ref StringSet.empty -+(* Label of glue code for calling the GC *) -+let call_gc_label = ref 0 -+(* Label of jump table *) -+let lbl_jumptbl = ref 0 -+(* List of all labels in jumptable (reverse order) *) -+let jumptbl_entries = ref [] -+(* Number of jumptable entries *) -+let num_jumptbl_entries = ref 0 -+ -+(* Fixup conditional branches that exceed hardware allowed range *) -+ -+let load_store_size = function -+ Ibased(s, d) -> 2 -+ | Iindexed ofs -> if is_immediate ofs then 1 else 3 -+ | Iindexed2 -> 1 -+ -+let instr_size = function -+ Lend -> 0 -+ | Lop(Imove | Ispill | Ireload) -> 1 -+ | Lop(Iconst_int n) -> if is_native_immediate n then 1 else 2 -+ | Lop(Iconst_float s) -> 2 -+ | Lop(Iconst_symbol s) -> 2 -+ | Lop(Icall_ind) -> 6 -+ | Lop(Icall_imm s) -> 7 -+ | Lop(Itailcall_ind) -> if !contains_calls then 7 else if has_stack_frame() then 5 else 4 -+ | Lop(Itailcall_imm s) -> if s = !function_name then 1 else -+ if !contains_calls then 8 else -+ if has_stack_frame() then 6 else 5 -+ | Lop(Iextcall(s, true)) -> 8 -+ | Lop(Iextcall(s, false)) -> 7 -+ | Lop(Istackoffset n) -> 0 -+ | Lop(Iload(chunk, addr)) -> -+ if chunk = Byte_signed -+ then load_store_size addr + 1 -+ else load_store_size addr -+ | Lop(Istore(chunk, addr)) -> load_store_size addr -+ | Lop(Ialloc n) -> 4 -+ | Lop(Ispecific(Ialloc_far n)) -> 5 -+ | Lop(Iintop Imod) -> 3 -+ | Lop(Iintop(Icomp cmp)) -> 4 -+ | Lop(Iintop op) -> 1 -+ | Lop(Iintop_imm(Idiv, n)) -> 2 -+ | Lop(Iintop_imm(Imod, n)) -> 4 -+ | Lop(Iintop_imm(Icomp cmp, n)) -> 4 -+ | Lop(Iintop_imm(op, n)) -> 1 -+ | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 -+ | Lop(Ifloatofint) -> 3 -+ | Lop(Iintoffloat) -> 3 -+ | Lop(Ispecific sop) -> 1 -+ | Lreloadretaddr -> 2 -+ | Lreturn -> if has_stack_frame() then 2 else 1 -+ | Llabel lbl -> 0 -+ | Lbranch lbl -> 1 -+ | Lcondbranch(tst, lbl) -> 2 -+ | Lcondbranch3(lbl0, lbl1, lbl2) -> -+ 1 + (if lbl0 = None then 0 else 1) -+ + (if lbl1 = None then 0 else 1) -+ + (if lbl2 = None then 0 else 1) -+ | Lswitch jumptbl -> 7 -+ | Lsetuptrap lbl -> 1 -+ | Lpushtrap -> 7 -+ | Lpoptrap -> 1 -+ | Lraise -> 6 -+ -+let label_map code = -+ let map = Hashtbl.create 37 in -+ let rec fill_map pc instr = -+ match instr.desc with -+ Lend -> (pc, map) -+ | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next -+ | op -> fill_map (pc + instr_size op) instr.next -+ in fill_map 0 code -+ -+let max_branch_offset = 8180 -+(* 14-bit signed offset in words. Remember to cut some slack -+ for multi-word instructions where the branch can be anywhere in -+ the middle. 12 words of slack is plenty. *) -+ -+let branch_overflows map pc_branch lbl_dest = -+ let pc_dest = Hashtbl.find map lbl_dest in -+ let delta = pc_dest - (pc_branch + 1) in -+ delta <= -max_branch_offset || delta >= max_branch_offset -+ -+let opt_branch_overflows map pc_branch opt_lbl_dest = -+ match opt_lbl_dest with -+ None -> false -+ | Some lbl_dest -> branch_overflows map pc_branch lbl_dest -+ -+let fixup_branches codesize map code = -+ let expand_optbranch lbl n arg next = -+ match lbl with -+ None -> next -+ | Some l -> -+ instr_cons (Lcondbranch(Iinttest_imm(Isigned Ceq, n), l)) -+ arg [||] next in -+ let rec fixup did_fix pc instr = -+ match instr.desc with -+ Lend -> did_fix -+ | Lcondbranch(test, lbl) when branch_overflows map pc lbl -> -+ let lbl2 = new_label() in -+ let cont = -+ instr_cons (Lbranch lbl) [||] [||] -+ (instr_cons (Llabel lbl2) [||] [||] instr.next) in -+ instr.desc <- Lcondbranch(invert_test test, lbl2); -+ instr.next <- cont; -+ fixup true (pc + 2) instr.next -+ | Lcondbranch3(lbl0, lbl1, lbl2) -+ when opt_branch_overflows map pc lbl0 -+ || opt_branch_overflows map pc lbl1 -+ || opt_branch_overflows map pc lbl2 -> -+ let cont = -+ expand_optbranch lbl0 0 instr.arg -+ (expand_optbranch lbl1 1 instr.arg -+ (expand_optbranch lbl2 2 instr.arg instr.next)) in -+ instr.desc <- cont.desc; -+ instr.next <- cont.next; -+ fixup true pc instr -+ | Lop(Ialloc n) when codesize - pc >= max_branch_offset -> -+ instr.desc <- Lop(Ispecific(Ialloc_far n)); -+ fixup true (pc + 4) instr.next -+ | op -> -+ fixup did_fix (pc + instr_size op) instr.next -+ in fixup false 0 code -+ -+(* Iterate branch expansion till all conditional branches are OK *) -+ -+let rec branch_normalization code = -+ let (codesize, map) = label_map code in -+ if codesize >= max_branch_offset && fixup_branches codesize map code -+ then branch_normalization code -+ else () -+ -+ -+(* Output the assembly code for an instruction *) -+ -+let rec emit_instr i dslot = -+ match i.desc with -+ Lend -> () -+ | Lop(Imove | Ispill | Ireload) -> -+ let src = i.arg.(0) and dst = i.res.(0) in -+ if src.loc <> dst.loc then begin -+ match (src, dst) with -+ {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> -+ ` mr {emit_reg dst}, {emit_reg src}\n` -+ | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> -+ ` fmr {emit_reg dst}, {emit_reg src}\n` -+ | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> -+ ` std {emit_reg src}, {emit_stack dst}\n` -+ | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> -+ ` stfd {emit_reg src}, {emit_stack dst}\n` -+ | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> -+ ` ld {emit_reg dst}, {emit_stack src}\n` -+ | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> -+ ` lfd {emit_reg dst}, {emit_stack src}\n` -+ | (_, _) -> -+ fatal_error "Emit: Imove" -+ end -+ | Lop(Iconst_int n) -> -+ if is_native_immediate n then -+ ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` -+ else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin -+ ` lis {emit_reg i.res.(0)}, {emit_int(nativehigh n)}\n`; -+ if nativelow n <> 0 then -+ ` ori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int(nativelow n)}\n` -+ end else begin -+ ` ld {emit_reg i.res.(0)}, {emit_tocref (TocInt n)}\n` -+ end -+ | Lop(Iconst_float s) -> -+ ` lfd {emit_reg i.res.(0)}, {emit_tocref (TocFloat s)}\n` -+ | Lop(Iconst_symbol s) -> -+ ` ld {emit_reg i.res.(0)}, {emit_tocref (TocSymOfs (s,0))}\n` -+ | Lop(Icall_ind) -> -+ ` std {emit_gpr 2},40({emit_gpr 1})\n`; -+ ` ld {emit_gpr 2}, 8({emit_reg i.arg.(0)})\n`; -+ ` ld {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(0)})\n`; -+ ` mtctr {emit_reg i.arg.(0)}\n`; -+ record_frame i.live; -+ ` bctrl\n`; -+ ` ld {emit_gpr 2},40({emit_gpr 1})\n` -+ | Lop(Icall_imm s) -> -+ ` ld {emit_gpr 11}, {emit_tocref (TocSymOfs (s,0))}\n`; -+ ` std {emit_gpr 2},40({emit_gpr 1})\n`; -+ ` ld {emit_gpr 2}, 8({emit_gpr 11})\n`; -+ ` ld {emit_gpr 11}, 0({emit_gpr 11})\n`; -+ ` mtctr {emit_gpr 11}\n`; -+ record_frame i.live; -+ ` bctrl\n`; -+ ` ld {emit_gpr 2},40({emit_gpr 1})\n` -+ | Lop(Itailcall_ind) -> -+ ` ld {emit_gpr 2}, 8({emit_reg i.arg.(0)})\n`; -+ ` ld {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(0)})\n`; -+ ` mtctr {emit_reg i.arg.(0)}\n`; -+ if has_stack_frame() then -+ ` ld {emit_gpr 1}, 0({emit_gpr 1})\n`; -+ if !contains_calls then begin -+ ` ld {emit_gpr 11}, 16({emit_gpr 1})\n`; -+ ` mtlr {emit_gpr 11}\n` -+ end; -+ ` bctr\n` -+ | Lop(Itailcall_imm s) -> -+ if s = !function_name then -+ ` b {emit_label !tailrec_entry_point}\n` -+ else begin -+ if has_stack_frame() then -+ ` ld {emit_gpr 1}, 0({emit_gpr 1})\n`; -+ if !contains_calls then begin -+ ` ld {emit_gpr 11}, 16({emit_gpr 1})\n`; -+ ` mtlr {emit_gpr 11}\n` -+ end; -+ ` ld {emit_gpr 11}, {emit_tocref (TocSymOfs (s,0))}\n`; -+ ` ld {emit_gpr 2}, 8({emit_gpr 11})\n`; -+ ` ld {emit_gpr 11}, 0({emit_gpr 11})\n`; -+ ` mtctr {emit_gpr 11}\n`; -+ ` bctr\n` -+ end -+ | Lop(Iextcall(s, alloc)) -> -+ if alloc then begin -+ ` ld {emit_gpr 11}, {emit_tocref (TocSymOfs (s,0))}\n`; -+ ` ld {emit_gpr 12}, {emit_tocref (TocSymOfs ("caml_c_call",0))}\n`; -+ end else -+ ` ld {emit_gpr 12}, {emit_tocref (TocSymOfs (s,0))}\n`; -+ ` std {emit_gpr 2}, 40({emit_gpr 1})\n`; -+ ` ld {emit_gpr 2}, 8({emit_gpr 12})\n`; -+ ` ld {emit_gpr 12}, 0({emit_gpr 12})\n`; -+ ` mtctr {emit_gpr 12}\n`; -+ if alloc then record_frame i.live; -+ ` bctrl\n`; -+ ` ld {emit_gpr 2}, 40({emit_gpr 1})\n` -+ | Lop(Istackoffset n) -> -+ if n > !stack_args_size then -+ stack_args_size := n -+ | Lop(Iload(chunk, addr)) -> -+ let loadinstr = -+ match chunk with -+ Byte_unsigned -> "lbz" -+ | Byte_signed -> "lbz" -+ | Sixteen_unsigned -> "lhz" -+ | Sixteen_signed -> "lha" -+ | Thirtytwo_unsigned -> "lwz" -+ | Thirtytwo_signed -> "lwa" -+ | Word -> "ld" -+ | Single -> "lfs" -+ | Double | Double_u -> "lfd" in -+ emit_load_store loadinstr addr i.arg 0 i.res.(0); -+ if chunk = Byte_signed then -+ ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` -+ | Lop(Istore(chunk, addr)) -> -+ let storeinstr = -+ match chunk with -+ Byte_unsigned | Byte_signed -> "stb" -+ | Sixteen_unsigned | Sixteen_signed -> "sth" -+ | Thirtytwo_unsigned | Thirtytwo_signed -> "stw" -+ | Word -> "std" -+ | Single -> "stfs" -+ | Double | Double_u -> "stfd" in -+ emit_load_store storeinstr addr i.arg 1 i.arg.(0) -+ | Lop(Ialloc n) -> -+ if !call_gc_label = 0 then call_gc_label := new_label(); -+ ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; -+ ` cmpld {emit_gpr 31}, {emit_gpr 30}\n`; -+ ` addi {emit_reg i.res.(0)}, {emit_gpr 31}, 8\n`; -+ record_frame i.live; -+ ` bltl {emit_label !call_gc_label}\n` (* Must be 4 insns to restart *) -+ | Lop(Ispecific(Ialloc_far n)) -> -+ if !call_gc_label = 0 then call_gc_label := new_label(); -+ let lbl = new_label() in -+ ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; -+ ` cmpld {emit_gpr 31}, {emit_gpr 30}\n`; -+ ` bge {emit_label lbl}\n`; -+ record_frame i.live; -+ ` bl {emit_label !call_gc_label}\n`; (* Must be 4 insns to restart *) -+ `{emit_label lbl}: addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n` -+ | Lop(Iintop Isub) -> (* subfc has swapped arguments *) -+ ` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` -+ | Lop(Iintop Imod) -> -+ ` divd {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ ` mulld {emit_gpr 0}, {emit_gpr 0}, {emit_reg i.arg.(1)}\n`; -+ ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` -+ | Lop(Iintop(Icomp cmp)) -> -+ begin match cmp with -+ Isigned c -> -+ ` cmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ emit_set_comp c i.res.(0) -+ | Iunsigned c -> -+ ` cmpld {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ emit_set_comp c i.res.(0) -+ end -+ | Lop(Iintop Icheckbound) -> -+ ` tdlle {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` -+ | Lop(Iintop op) -> -+ let instr = name_for_intop op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` -+ | Lop(Iintop_imm(Isub, n)) -> -+ ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n` -+ | Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *) -+ let l = Misc.log2 n in -+ ` sradi {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` -+ | Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *) -+ let l = Misc.log2 n in -+ ` sradi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; -+ ` addze {emit_gpr 0}, {emit_gpr 0}\n`; -+ ` sldi {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` -+ | Lop(Iintop_imm(Icomp cmp, n)) -> -+ begin match cmp with -+ Isigned c -> -+ ` cmpdi {emit_reg i.arg.(0)}, {emit_int n}\n`; -+ emit_set_comp c i.res.(0) -+ | Iunsigned c -> -+ ` cmpldi {emit_reg i.arg.(0)}, {emit_int n}\n`; -+ emit_set_comp c i.res.(0) -+ end -+ | Lop(Iintop_imm(Icheckbound, n)) -> -+ ` tdllei {emit_reg i.arg.(0)}, {emit_int n}\n` -+ | Lop(Iintop_imm(op, n)) -> -+ let instr = name_for_intop_imm op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n` -+ | Lop(Inegf | Iabsf as op) -> -+ let instr = name_for_floatop1 op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` -+ | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> -+ let instr = name_for_floatop2 op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` -+ | Lop(Ifloatofint) -> -+ let ofs = if has_stack_frame() then 16 else 8 * (2 + num_stack_slots.(0) + num_stack_slots.(1)) in -+ ` std {emit_reg i.arg.(0)}, -{emit_int ofs}({emit_gpr 1})\n`; -+ ` lfd {emit_reg i.res.(0)}, -{emit_int ofs}({emit_gpr 1})\n`; -+ ` fcfid {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` -+ | Lop(Iintoffloat) -> -+ let ofs = if has_stack_frame() then 16 else 8 * (2 + num_stack_slots.(0) + num_stack_slots.(1)) in -+ ` fctidz {emit_fpr 0}, {emit_reg i.arg.(0)}\n`; -+ ` stfd {emit_fpr 0}, -{emit_int ofs}({emit_gpr 1})\n`; -+ ` ld {emit_reg i.res.(0)}, -{emit_int ofs}({emit_gpr 1})\n` -+ | Lop(Ispecific sop) -> -+ let instr = name_for_specific sop in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` -+ | Lreloadretaddr -> -+ if has_stack_frame() then begin -+ ` ld {emit_gpr 11}, {emit_label !stack_size_lbl}+16({emit_gpr 1})\n`; -+ ` mtlr {emit_gpr 11}\n` -+ end -+ | Lreturn -> -+ if has_stack_frame() then -+ ` ld {emit_gpr 1}, 0({emit_gpr 1})\n`; -+ ` blr\n` -+ | Llabel lbl -> -+ `{emit_label lbl}:\n` -+ | Lbranch lbl -> -+ ` b {emit_label lbl}\n` -+ | Lcondbranch(tst, lbl) -> -+ begin match tst with -+ Itruetest -> -+ ` cmpdi {emit_reg i.arg.(0)}, 0\n`; -+ emit_delay dslot; -+ ` bne {emit_label lbl}\n` -+ | Ifalsetest -> -+ ` cmpdi {emit_reg i.arg.(0)}, 0\n`; -+ emit_delay dslot; -+ ` beq {emit_label lbl}\n` -+ | Iinttest cmp -> -+ let (comp, branch) = name_for_int_comparison cmp in -+ ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ emit_delay dslot; -+ ` {emit_string branch} {emit_label lbl}\n` -+ | Iinttest_imm(cmp, n) -> -+ let (comp, branch) = name_for_int_comparison cmp in -+ ` {emit_string comp}i {emit_reg i.arg.(0)}, {emit_int n}\n`; -+ emit_delay dslot; -+ ` {emit_string branch} {emit_label lbl}\n` -+ | Ifloattest(cmp, neg) -> -+ ` fcmpu {emit_ccr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ (* bit 0 = lt, bit 1 = gt, bit 2 = eq *) -+ let (bitnum, negtst) = -+ match cmp with -+ Ceq -> (2, neg) -+ | Cne -> (2, not neg) -+ | Cle -> ` cror 3, 0, 2\n`; (* lt or eq *) -+ (3, neg) -+ | Cgt -> (1, neg) -+ | Cge -> ` cror 3, 1, 2\n`; (* gt or eq *) -+ (3, neg) -+ | Clt -> (0, neg) in -+ emit_delay dslot; -+ if negtst -+ then ` bf {emit_int bitnum}, {emit_label lbl}\n` -+ else ` bt {emit_int bitnum}, {emit_label lbl}\n` -+ | Ioddtest -> -+ ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; -+ emit_delay dslot; -+ ` bne {emit_label lbl}\n` -+ | Ieventest -> -+ ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; -+ emit_delay dslot; -+ ` beq {emit_label lbl}\n` -+ end -+ | Lcondbranch3(lbl0, lbl1, lbl2) -> -+ ` cmpdi {emit_reg i.arg.(0)}, 1\n`; -+ emit_delay dslot; -+ begin match lbl0 with -+ None -> () -+ | Some lbl -> ` blt {emit_label lbl}\n` -+ end; -+ begin match lbl1 with -+ None -> () -+ | Some lbl -> ` beq {emit_label lbl}\n` -+ end; -+ begin match lbl2 with -+ None -> () -+ | Some lbl -> ` bgt {emit_label lbl}\n` -+ end -+ | Lswitch jumptbl -> -+ if !lbl_jumptbl = 0 then lbl_jumptbl := new_label(); -+ ` ld {emit_gpr 11}, {emit_tocref (TocLabel !lbl_jumptbl)}\n`; -+ ` addi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int !num_jumptbl_entries}\n`; -+ ` sldi {emit_gpr 0}, {emit_gpr 0}, 2\n`; -+ ` lwax {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; -+ ` add {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; -+ ` mtctr {emit_gpr 0}\n`; -+ ` bctr\n`; -+ for i = 0 to Array.length jumptbl - 1 do -+ jumptbl_entries := jumptbl.(i) :: !jumptbl_entries; -+ incr num_jumptbl_entries -+ done -+ | Lsetuptrap lbl -> -+ ` bl {emit_label lbl}\n`; -+ | Lpushtrap -> -+ stack_traps_size := !stack_traps_size + 32; -+ ` addi {emit_gpr 11}, {emit_gpr 1}, {emit_label !stack_size_lbl}-{emit_int !stack_traps_size}\n`; -+ ` mflr {emit_gpr 0}\n`; -+ ` std {emit_gpr 29}, 0({emit_gpr 11})\n`; -+ ` std {emit_gpr 0}, 8({emit_gpr 11})\n`; -+ ` std {emit_gpr 1}, 16({emit_gpr 11})\n`; -+ ` std {emit_gpr 2}, 24({emit_gpr 11})\n`; -+ ` mr {emit_gpr 29}, {emit_gpr 11}\n` -+ | Lpoptrap -> -+ ` ld {emit_gpr 29}, 0({emit_gpr 29})\n` -+ | Lraise -> -+ ` ld {emit_gpr 0}, 8({emit_gpr 29})\n`; -+ ` ld {emit_gpr 1}, 16({emit_gpr 29})\n`; -+ ` ld {emit_gpr 2}, 24({emit_gpr 29})\n`; -+ ` mtlr {emit_gpr 0}\n`; -+ ` ld {emit_gpr 29}, 0({emit_gpr 29})\n`; -+ ` blr\n` -+ -+and emit_delay = function -+ None -> () -+ | Some i -> emit_instr i None -+ -+(* Checks if a pseudo-instruction expands to instructions -+ that do not branch and do not affect CR0 nor R12. *) -+ -+let is_simple_instr i = -+ match i.desc with -+ Lop op -> -+ begin match op with -+ Icall_imm _ | Icall_ind | Itailcall_imm _ | Itailcall_ind | -+ Iextcall(_, _) -> false -+ | Ialloc(_) -> false -+ | Iintop(Icomp _) -> false -+ | Iintop_imm(Iand, _) -> false -+ | Iintop_imm(Icomp _, _) -> false -+ | _ -> true -+ end -+ | Lreloadretaddr -> true -+ | _ -> false -+ -+let no_interference res arg = -+ try -+ for i = 0 to Array.length arg - 1 do -+ for j = 0 to Array.length res - 1 do -+ if arg.(i).loc = res.(j).loc then raise Exit -+ done -+ done; -+ true -+ with Exit -> -+ false -+ -+(* Emit a sequence of instructions, trying to fill delay slots for branches *) -+ -+let rec emit_all i = -+ match i with -+ {desc = Lend} -> () -+ | {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}} -+ when is_simple_instr i && no_interference i.res i.next.arg -> -+ emit_instr i.next (Some i); -+ emit_all i.next.next -+ | _ -> -+ emit_instr i None; -+ emit_all i.next -+ -+(* Emission of a function declaration *) -+ -+let fundecl fundecl = -+ function_name := fundecl.fun_name; -+ defined_functions := StringSet.add fundecl.fun_name !defined_functions; -+ tailrec_entry_point := new_label(); -+ if has_stack_frame() then -+ stack_size_lbl := new_label(); -+ stack_slot_lbl := new_label(); -+ stack_args_size := 0; -+ stack_traps_size := 0; -+ call_gc_label := 0; -+ ` .globl {emit_symbol fundecl.fun_name}\n`; -+ begin match Config.system with -+ | "elf" | "bsd" -> -+ ` .section \".opd\",\"aw\"\n`; -+ ` .align 3\n`; -+ ` .type {emit_symbol fundecl.fun_name}, @function\n`; -+ `{emit_symbol fundecl.fun_name}:\n`; -+ ` .quad .L.{emit_symbol fundecl.fun_name},.TOC.@tocbase\n`; -+ ` .previous\n`; -+ ` .align 2\n`; -+ emit_string code_space; -+ `.L.{emit_symbol fundecl.fun_name}:\n` -+ | _ -> -+ ` .align 2\n`; -+ emit_string code_space; -+ `{emit_symbol fundecl.fun_name}:\n` -+ end; -+ if !contains_calls then begin -+ ` mflr {emit_gpr 0}\n`; -+ ` std {emit_gpr 0}, 16({emit_gpr 1})\n` -+ end; -+ if has_stack_frame() then -+ ` stdu {emit_gpr 1}, -{emit_label !stack_size_lbl}({emit_gpr 1})\n`; -+ `{emit_label !tailrec_entry_point}:\n`; -+ branch_normalization fundecl.fun_body; -+ emit_all fundecl.fun_body; -+ ` .size .L.{emit_symbol fundecl.fun_name}, . - .L.{emit_symbol fundecl.fun_name}\n`; -+ if has_stack_frame() then begin -+ ` .set {emit_label !stack_size_lbl},{emit_int (frame_size_sans_args() + !stack_args_size + !stack_traps_size)} # stack size including traps\n`; -+ ` .set {emit_label !stack_slot_lbl},{emit_int (48 + !stack_args_size)} # stack slot offset\n` -+ end else (* leave 8 bytes for float <-> conversions *) -+ ` .set {emit_label !stack_slot_lbl},{emit_int (40-frame_size_sans_args())} # stack slot offset (negative)\n`; -+ -+ (* Emit the glue code to call the GC *) -+ if !call_gc_label > 0 then begin -+ `{emit_label !call_gc_label}:\n`; -+ ` ld {emit_gpr 12}, {emit_tocref (TocSymOfs ("caml_call_gc",0))}\n`; -+ ` ld {emit_gpr 12}, 0({emit_gpr 12})\n`; -+ ` mtctr {emit_gpr 12}\n`; -+ ` bctr\n`; -+ end -+ -+(* Emission of data *) -+ -+let declare_global_data s = -+ ` .globl {emit_symbol s}\n`; -+ if Config.system = "elf" || Config.system = "bsd" then -+ ` .type {emit_symbol s}, @object\n` -+ -+let emit_item = function -+ Cglobal_symbol s -> -+ declare_global_data s -+ | Cdefine_symbol s -> -+ `{emit_symbol s}:\n`; -+ | Cdefine_label lbl -> -+ `{emit_label (lbl + 100000)}:\n` -+ | Cint8 n -> -+ ` .byte {emit_int n}\n` -+ | Cint16 n -> -+ ` .short {emit_int n}\n` -+ | Cint32 n -> -+ ` .long {emit_nativeint n}\n` -+ | Cint n -> -+ ` .quad {emit_nativeint n}\n` -+ | Csingle f -> -+ ` .float 0d{emit_string f}\n` -+ | Cdouble f -> -+ ` .double 0d{emit_string f}\n` -+ | Csymbol_address s -> -+ ` .quad {emit_symbol s}\n` -+ | Clabel_address lbl -> -+ ` .quad {emit_label (lbl + 100000)}\n` -+ | Cstring s -> -+ emit_bytes_directive " .byte " s -+ | Cskip n -> -+ if n > 0 then ` .space {emit_int n}\n` -+ | Calign n -> -+ ` .align {emit_int (Misc.log2 n)}\n` -+ -+let data l = -+ emit_string data_space; -+ List.iter emit_item l -+ -+(* Beginning / end of an assembly file *) -+ -+let begin_assembly() = -+ defined_functions := StringSet.empty; -+ external_functions := StringSet.empty; -+ tocref_entries := []; -+ num_jumptbl_entries := 0; -+ jumptbl_entries := []; -+ lbl_jumptbl := 0; -+ (* Emit the beginning of the segments *) -+ let lbl_begin = Compilenv.make_symbol (Some "data_begin") in -+ emit_string data_space; -+ declare_global_data lbl_begin; -+ `{emit_symbol lbl_begin}:\n`; -+ let lbl_begin = Compilenv.make_symbol (Some "code_begin") in -+ emit_string code_space; -+ declare_global_data lbl_begin; -+ `{emit_symbol lbl_begin}:\n` -+ -+let end_assembly() = -+ (* Emit the jump table *) -+ if !num_jumptbl_entries > 0 then begin -+ emit_string code_space; -+ `{emit_label !lbl_jumptbl}:\n`; -+ List.iter -+ (fun lbl -> ` .long {emit_label lbl} - {emit_label !lbl_jumptbl}\n`) -+ (List.rev !jumptbl_entries); -+ jumptbl_entries := [] -+ end; -+ if !tocref_entries <> [] then begin -+ emit_string toc_space; -+ List.iter -+ (fun (lbl, entry) -> -+ `{emit_label lbl}:\n`; -+ match entry with -+ TocFloat f -> -+ ` .double {emit_tocentry entry}\n` -+ | _ -> -+ ` .tc {emit_label lbl}[TC],{emit_tocentry entry}\n` -+ ) -+ !tocref_entries; -+ tocref_entries := [] -+ end; -+ if pic_externals then -+ (* Emit the pointers to external functions *) -+ StringSet.iter emit_external !external_functions; -+ (* Emit the end of the segments *) -+ emit_string code_space; -+ let lbl_end = Compilenv.make_symbol (Some "code_end") in -+ declare_global_data lbl_end; -+ `{emit_symbol lbl_end}:\n`; -+ ` .long 0\n`; -+ emit_string data_space; -+ let lbl_end = Compilenv.make_symbol (Some "data_end") in -+ declare_global_data lbl_end; -+ `{emit_symbol lbl_end}:\n`; -+ ` .quad 0\n`; -+ (* Emit the frame descriptors *) -+ emit_string rodata_space; -+ let lbl = Compilenv.make_symbol (Some "frametable") in -+ declare_global_data lbl; -+ `{emit_symbol lbl}:\n`; -+ ` .quad {emit_int (List.length !frame_descriptors)}\n`; -+ List.iter emit_frame !frame_descriptors; -+ frame_descriptors := [] -diff --git a/asmcomp/power64/proc.ml b/asmcomp/power64/proc.ml -new file mode 100644 -index 0000000..372303d ---- /dev/null -+++ b/asmcomp/power64/proc.ml -@@ -0,0 +1,240 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: proc.ml 9547 2010-01-22 12:48:24Z doligez $ *) -+ -+(* Description of the Power PC *) -+ -+open Misc -+open Cmm -+open Reg -+open Arch -+open Mach -+ -+(* Instruction selection *) -+ -+let word_addressed = false -+ -+(* Registers available for register allocation *) -+ -+(* Integer register map: -+ 0 temporary, null register for some operations -+ 1 stack pointer -+ 2 pointer to table of contents -+ 3 - 10 function arguments and results -+ 11 - 12 temporaries -+ 13 pointer to small data area -+ 14 - 28 general purpose, preserved by C -+ 29 trap pointer -+ 30 allocation limit -+ 31 allocation pointer -+ Floating-point register map: -+ 0 temporary -+ 1 - 13 function arguments and results -+ 14 - 31 general purpose, preserved by C -+*) -+ -+let int_reg_name = -+ if Config.system = "rhapsody" then -+ [| "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "r10"; -+ "r14"; "r15"; "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; -+ "r22"; "r23"; "r24"; "r25"; "r26"; "r27"; "r28" |] -+ else -+ [| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; -+ "14"; "15"; "16"; "17"; "18"; "19"; "20"; "21"; -+ "22"; "23"; "24"; "25"; "26"; "27"; "28" |] -+ -+let float_reg_name = -+ if Config.system = "rhapsody" then -+ [| "f1"; "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; "f8"; -+ "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; "f16"; -+ "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23"; "f24"; -+ "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31" |] -+ else -+ [| "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"; "31" |] -+ -+let num_register_classes = 2 -+ -+let register_class r = -+ match r.typ with -+ Int -> 0 -+ | Addr -> 0 -+ | Float -> 1 -+ -+let num_available_registers = [| 23; 31 |] -+ -+let first_available_register = [| 0; 100 |] -+ -+let register_name r = -+ if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) -+ -+let rotate_registers = true -+ -+(* Representation of hard registers by pseudo-registers *) -+ -+let hard_int_reg = -+ let v = Array.create 23 Reg.dummy in -+ for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v -+ -+let hard_float_reg = -+ let v = Array.create 31 Reg.dummy in -+ for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v -+ -+let all_phys_regs = -+ Array.append hard_int_reg hard_float_reg -+ -+let phys_reg n = -+ if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) -+ -+let stack_slot slot ty = -+ Reg.at_location ty (Stack slot) -+ -+(* Calling conventions *) -+ -+let calling_conventions -+ first_int last_int first_float last_float make_stack stack_ofs arg = -+ let loc = Array.create (Array.length arg) Reg.dummy in -+ let int = ref first_int in -+ let float = ref first_float in -+ let ofs = ref stack_ofs in -+ for i = 0 to Array.length arg - 1 do -+ match arg.(i).typ with -+ Int | Addr as ty -> -+ if !int <= last_int then begin -+ loc.(i) <- phys_reg !int; -+ incr int -+ end else begin -+ loc.(i) <- stack_slot (make_stack !ofs) ty; -+ end; -+ ofs := !ofs + size_int -+ | Float -> -+ if !float <= last_float then begin -+ loc.(i) <- phys_reg !float; -+ incr float -+ end else begin -+ loc.(i) <- stack_slot (make_stack !ofs) Float; -+ end; -+ ofs := !ofs + size_float -+ done; -+ (loc, Misc.align !ofs 16) -+ (* Keep stack 16-aligned. *) -+ -+let incoming ofs = Incoming ofs -+let outgoing ofs = Outgoing ofs -+let not_supported ofs = fatal_error "Proc.loc_results: cannot call" -+ -+let loc_arguments arg = -+ calling_conventions 0 7 100 112 outgoing 48 arg -+let loc_parameters arg = -+ let (loc, ofs) = calling_conventions 0 7 100 112 incoming 0 arg in loc -+let loc_results res = -+ let (loc, ofs) = calling_conventions 0 7 100 112 not_supported 0 res in loc -+ -+(* C calling conventions under PowerOpen: -+ use GPR 3-10 and FPR 1-13 just like ML calling -+ conventions, but always reserve stack space for all arguments. -+ Also, using a float register automatically reserves two int registers -+ (in 32-bit mode) or one int register (in 64-bit mode). -+ (If we were to call a non-prototyped C function, each float argument -+ would have to go both in a float reg and in the matching pair -+ of integer regs.) -+ -+ C calling conventions under SVR4: -+ use GPR 3-10 and FPR 1-8 just like ML calling conventions. -+ Using a float register does not affect the int registers. -+ Always reserve 8 bytes at bottom of stack, plus whatever is needed -+ to hold the overflow arguments. *) -+ -+let poweropen_external_conventions first_int last_int -+ first_float last_float arg = -+ let loc = Array.create (Array.length arg) Reg.dummy in -+ let int = ref first_int in -+ let float = ref first_float in -+ let ofs = ref (14 * size_addr) in -+ for i = 0 to Array.length arg - 1 do -+ match arg.(i).typ with -+ Int | Addr as ty -> -+ if !int <= last_int then begin -+ loc.(i) <- phys_reg !int; -+ incr int -+ end else begin -+ loc.(i) <- stack_slot (Outgoing !ofs) ty; -+ ofs := !ofs + size_int -+ end -+ | Float -> -+ if !float <= last_float then begin -+ loc.(i) <- phys_reg !float; -+ incr float -+ end else begin -+ loc.(i) <- stack_slot (Outgoing !ofs) Float; -+ ofs := !ofs + size_float -+ end; -+ int := !int + 1 -+ done; -+ (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) -+ -+let loc_external_arguments = -+ match Config.system with -+ | "rhapsody" -> poweropen_external_conventions 0 7 100 112 -+ | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 48 -+ | _ -> assert false -+ -+let extcall_use_push = false -+ -+(* Results are in GPR 3 and FPR 1 *) -+ -+let loc_external_results res = -+ let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc -+ -+(* Exceptions are in GPR 3 *) -+ -+let loc_exn_bucket = phys_reg 0 -+ -+(* Registers destroyed by operations *) -+ -+let destroyed_at_c_call = -+ Array.of_list(List.map phys_reg -+ [0; 1; 2; 3; 4; 5; 6; 7; -+ 100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112]) -+ -+let destroyed_at_oper = function -+ Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs -+ | Iop(Iextcall(_, false)) -> destroyed_at_c_call -+ | _ -> [||] -+ -+let destroyed_at_raise = all_phys_regs -+ -+(* Maximal register pressure *) -+ -+let safe_register_pressure = function -+ Iextcall(_, _) -> 15 -+ | _ -> 23 -+ -+let max_register_pressure = function -+ Iextcall(_, _) -> [| 15; 18 |] -+ | _ -> [| 23; 30 |] -+ -+(* Layout of the stack *) -+ -+let num_stack_slots = [| 0; 0 |] -+let contains_calls = ref false -+ -+(* Calling the assembler *) -+ -+let assemble_file infile outfile = -+ Ccomp.command (Config.asm ^ " -o " ^ -+ Filename.quote outfile ^ " " ^ Filename.quote infile) -+ -+let init () = () -diff --git a/asmcomp/power64/reload.ml b/asmcomp/power64/reload.ml -new file mode 100644 -index 0000000..abcac6c ---- /dev/null -+++ b/asmcomp/power64/reload.ml -@@ -0,0 +1,18 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: reload.ml 2553 1999-11-17 18:59:06Z xleroy $ *) -+ -+(* Reloading for the PowerPC *) -+ -+let fundecl f = -+ (new Reloadgen.reload_generic)#fundecl f -diff --git a/asmcomp/power64/scheduling.ml b/asmcomp/power64/scheduling.ml -new file mode 100644 -index 0000000..b7bba9b ---- /dev/null -+++ b/asmcomp/power64/scheduling.ml -@@ -0,0 +1,65 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: scheduling.ml 9547 2010-01-22 12:48:24Z doligez $ *) -+ -+(* Instruction scheduling for the Power PC *) -+ -+open Arch -+open Mach -+ -+class scheduler = object -+ -+inherit Schedgen.scheduler_generic -+ -+(* Latencies (in cycles). Based roughly on the "common model". *) -+ -+method oper_latency = function -+ Ireload -> 2 -+ | Iload(_, _) -> 2 -+ | Iconst_float _ -> 2 (* turned into a load *) -+ | Iconst_symbol _ -> 1 -+ | Iintop Imul -> 9 -+ | Iintop_imm(Imul, _) -> 5 -+ | Iintop(Idiv | Imod) -> 36 -+ | Iaddf | Isubf -> 4 -+ | Imulf -> 5 -+ | Idivf -> 33 -+ | Ispecific(Imultaddf | Imultsubf) -> 5 -+ | _ -> 1 -+ -+method reload_retaddr_latency = 12 -+ (* If we can have that many cycles between the reloadretaddr and the -+ return, we can expect that the blr branch will be completely folded. *) -+ -+(* Issue cycles. Rough approximations. *) -+ -+method oper_issue_cycles = function -+ Iconst_float _ | Iconst_symbol _ -> 2 -+ | Iload(_, Ibased(_, _)) -> 2 -+ | Istore(_, Ibased(_, _)) -> 2 -+ | Ialloc _ -> 4 -+ | Iintop(Imod) -> 40 (* assuming full stall *) -+ | Iintop(Icomp _) -> 4 -+ | Iintop_imm(Idiv, _) -> 2 -+ | Iintop_imm(Imod, _) -> 4 -+ | Iintop_imm(Icomp _, _) -> 4 -+ | Ifloatofint -> 9 -+ | Iintoffloat -> 4 -+ | _ -> 1 -+ -+method reload_retaddr_issue_cycles = 3 -+ (* load then stalling mtlr *) -+ -+end -+ -+let fundecl f = (new scheduler)#schedule_fundecl f -diff --git a/asmcomp/power64/selection.ml b/asmcomp/power64/selection.ml -new file mode 100644 -index 0000000..53b7828 ---- /dev/null -+++ b/asmcomp/power64/selection.ml -@@ -0,0 +1,101 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1997 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: selection.ml 10296 2010-04-22 12:51:06Z xleroy $ *) -+ -+(* Instruction selection for the Power PC processor *) -+ -+open Cmm -+open Arch -+open Mach -+ -+(* Recognition of addressing modes *) -+ -+type addressing_expr = -+ Asymbol of string -+ | Alinear of expression -+ | Aadd of expression * expression -+ -+let rec select_addr = function -+ Cconst_symbol s -> -+ (Asymbol s, 0) -+ | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> -+ let (a, n) = select_addr arg in (a, n + m) -+ | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> -+ let (a, n) = select_addr arg in (a, n + m) -+ | Cop((Caddi | Cadda), [arg1; arg2]) -> -+ begin match (select_addr arg1, select_addr arg2) with -+ ((Alinear e1, n1), (Alinear e2, n2)) -> -+ (Aadd(e1, e2), n1 + n2) -+ | _ -> -+ (Aadd(arg1, arg2), 0) -+ end -+ | exp -> -+ (Alinear exp, 0) -+ -+(* Instruction selection *) -+ -+class selector = object (self) -+ -+inherit Selectgen.selector_generic as super -+ -+method is_immediate n = (n <= 32767) && (n >= -32768) -+ -+method select_addressing chunk exp = -+ match select_addr exp with -+ (Asymbol s, d) -> -+ (Ibased(s, d), Ctuple []) -+ | (Alinear e, d) -> -+ (Iindexed d, e) -+ | (Aadd(e1, e2), d) -> -+ if d = 0 -+ then (Iindexed2, Ctuple[e1; e2]) -+ else (Iindexed d, Cop(Cadda, [e1; e2])) -+ -+method! select_operation op args = -+ match (op, args) with -+ (* Prevent the recognition of (x / cst) and (x % cst) when cst is not -+ a power of 2, which do not correspond to an instruction. *) -+ (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> -+ (Iintop_imm(Idiv, n), [arg]) -+ | (Cdivi, _) -> -+ (Iintop Idiv, args) -+ | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> -+ (Iintop_imm(Imod, n), [arg]) -+ | (Cmodi, _) -> -+ (Iintop Imod, args) -+ (* The and, or and xor instructions have a different range of immediate -+ operands than the other instructions *) -+ | (Cand, _) -> self#select_logical Iand args -+ | (Cor, _) -> self#select_logical Ior args -+ | (Cxor, _) -> self#select_logical Ixor args -+ (* Recognize mult-add and mult-sub instructions *) -+ | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> -+ (Ispecific Imultaddf, [arg1; arg2; arg3]) -+ | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> -+ (Ispecific Imultaddf, [arg1; arg2; arg3]) -+ | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> -+ (Ispecific Imultsubf, [arg1; arg2; arg3]) -+ | _ -> -+ super#select_operation op args -+ -+method select_logical op = function -+ [arg; Cconst_int n] when n >= 0 && n <= 0xFFFF -> -+ (Iintop_imm(op, n), [arg]) -+ | [Cconst_int n; arg] when n >= 0 && n <= 0xFFFF -> -+ (Iintop_imm(op, n), [arg]) -+ | args -> -+ (Iintop op, args) -+ -+end -+ -+let fundecl f = (new selector)#emit_fundecl f -diff --git a/asmrun/Makefile b/asmrun/Makefile -index 5ebf7aa..6a8ed98 100644 ---- a/asmrun/Makefile -+++ b/asmrun/Makefile -@@ -90,6 +90,12 @@ power.o: power-$(SYSTEM).o - power.p.o: power-$(SYSTEM).o - cp power-$(SYSTEM).o power.p.o - -+power64.o: power64-$(SYSTEM).o -+ cp power64-$(SYSTEM).o power64.o -+ -+power64.p.o: power64-$(SYSTEM).o -+ cp power64-$(SYSTEM).o power64.p.o -+ - main.c: ../byterun/main.c - ln -s ../byterun/main.c main.c - misc.c: ../byterun/misc.c -diff --git a/asmrun/power64-elf.S b/asmrun/power64-elf.S -new file mode 100644 -index 0000000..b2c24d6 ---- /dev/null -+++ b/asmrun/power64-elf.S -@@ -0,0 +1,486 @@ -+/*********************************************************************/ -+/* */ -+/* Objective Caml */ -+/* */ -+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -+/* */ -+/* Copyright 1996 Institut National de Recherche en Informatique et */ -+/* en Automatique. All rights reserved. This file is distributed */ -+/* under the terms of the GNU Library General Public License, with */ -+/* the special exception on linking described in file ../LICENSE. */ -+/* */ -+/*********************************************************************/ -+ -+/* $Id: ocaml-3.11.0-ppc64.patch,v 1.1 2008/11/20 15:30:55 rjones Exp $ */ -+ -+#define Addrglobal(reg,glob) \ -+ addis reg, 0, glob@ha; \ -+ addi reg, reg, glob@l -+#define Loadglobal(reg,glob,tmp) \ -+ addis tmp, 0, glob@ha; \ -+ ld reg, glob@l(tmp) -+#define Storeglobal(reg,glob,tmp) \ -+ addis tmp, 0, glob@ha; \ -+ std reg, glob@l(tmp) -+ -+ .section ".text" -+ -+/* Invoke the garbage collector. */ -+ -+ .globl caml_call_gc -+ .type caml_call_gc, @function -+ .section ".opd","aw" -+ .align 3 -+caml_call_gc: -+ .quad .L.caml_call_gc,.TOC.@tocbase -+ .previous -+ .align 2 -+.L.caml_call_gc: -+ /* Set up stack frame */ -+ mflr 0 -+ std 0, 16(1) -+ /* Record return address into Caml code */ -+ Storeglobal(0, caml_last_return_address, 11) -+ /* Record lowest stack address */ -+ Storeglobal(1, caml_bottom_of_stack, 11) -+ /* 0x220 = 8*32 (int regs) + 8*32 (float regs) + 48 (stack frame) */ -+ stdu 1, -0x230(1) -+ /* Record pointer to register array */ -+ addi 0, 1, 8*32 + 48 -+ Storeglobal(0, caml_gc_regs, 11) -+ /* Save current allocation pointer for debugging purposes */ -+ Storeglobal(31, caml_young_ptr, 11) -+ /* Save exception pointer (if e.g. a sighandler raises) */ -+ Storeglobal(29, caml_exception_pointer, 11) -+ /* Save all registers used by the code generator */ -+ addi 11, 1, 8*32 + 48 - 8 -+ stdu 3, 8(11) -+ stdu 4, 8(11) -+ stdu 5, 8(11) -+ stdu 6, 8(11) -+ stdu 7, 8(11) -+ stdu 8, 8(11) -+ stdu 9, 8(11) -+ stdu 10, 8(11) -+ stdu 14, 8(11) -+ stdu 15, 8(11) -+ stdu 16, 8(11) -+ stdu 17, 8(11) -+ stdu 18, 8(11) -+ stdu 19, 8(11) -+ stdu 20, 8(11) -+ stdu 21, 8(11) -+ stdu 22, 8(11) -+ stdu 23, 8(11) -+ stdu 24, 8(11) -+ stdu 25, 8(11) -+ stdu 26, 8(11) -+ stdu 27, 8(11) -+ stdu 28, 8(11) -+ addi 11, 1, 48 - 8 -+ stfdu 1, 8(11) -+ stfdu 2, 8(11) -+ stfdu 3, 8(11) -+ stfdu 4, 8(11) -+ stfdu 5, 8(11) -+ stfdu 6, 8(11) -+ stfdu 7, 8(11) -+ stfdu 8, 8(11) -+ stfdu 9, 8(11) -+ stfdu 10, 8(11) -+ stfdu 11, 8(11) -+ stfdu 12, 8(11) -+ stfdu 13, 8(11) -+ stfdu 14, 8(11) -+ stfdu 15, 8(11) -+ stfdu 16, 8(11) -+ stfdu 17, 8(11) -+ stfdu 18, 8(11) -+ stfdu 19, 8(11) -+ stfdu 20, 8(11) -+ stfdu 21, 8(11) -+ stfdu 22, 8(11) -+ stfdu 23, 8(11) -+ stfdu 24, 8(11) -+ stfdu 25, 8(11) -+ stfdu 26, 8(11) -+ stfdu 27, 8(11) -+ stfdu 28, 8(11) -+ stfdu 29, 8(11) -+ stfdu 30, 8(11) -+ stfdu 31, 8(11) -+ /* Call the GC */ -+ std 2,40(1) -+ Addrglobal(11, caml_garbage_collection) -+ ld 2,8(11) -+ ld 11,0(11) -+ mtlr 11 -+ blrl -+ ld 2,40(1) -+ /* Reload new allocation pointer and allocation limit */ -+ Loadglobal(31, caml_young_ptr, 11) -+ Loadglobal(30, caml_young_limit, 11) -+ /* Restore all regs used by the code generator */ -+ addi 11, 1, 8*32 + 48 - 8 -+ ldu 3, 8(11) -+ ldu 4, 8(11) -+ ldu 5, 8(11) -+ ldu 6, 8(11) -+ ldu 7, 8(11) -+ ldu 8, 8(11) -+ ldu 9, 8(11) -+ ldu 10, 8(11) -+ ldu 14, 8(11) -+ ldu 15, 8(11) -+ ldu 16, 8(11) -+ ldu 17, 8(11) -+ ldu 18, 8(11) -+ ldu 19, 8(11) -+ ldu 20, 8(11) -+ ldu 21, 8(11) -+ ldu 22, 8(11) -+ ldu 23, 8(11) -+ ldu 24, 8(11) -+ ldu 25, 8(11) -+ ldu 26, 8(11) -+ ldu 27, 8(11) -+ ldu 28, 8(11) -+ addi 11, 1, 48 - 8 -+ lfdu 1, 8(11) -+ lfdu 2, 8(11) -+ lfdu 3, 8(11) -+ lfdu 4, 8(11) -+ lfdu 5, 8(11) -+ lfdu 6, 8(11) -+ lfdu 7, 8(11) -+ lfdu 8, 8(11) -+ lfdu 9, 8(11) -+ lfdu 10, 8(11) -+ lfdu 11, 8(11) -+ lfdu 12, 8(11) -+ lfdu 13, 8(11) -+ lfdu 14, 8(11) -+ lfdu 15, 8(11) -+ lfdu 16, 8(11) -+ lfdu 17, 8(11) -+ lfdu 18, 8(11) -+ lfdu 19, 8(11) -+ lfdu 20, 8(11) -+ lfdu 21, 8(11) -+ lfdu 22, 8(11) -+ lfdu 23, 8(11) -+ lfdu 24, 8(11) -+ lfdu 25, 8(11) -+ lfdu 26, 8(11) -+ lfdu 27, 8(11) -+ lfdu 28, 8(11) -+ lfdu 29, 8(11) -+ lfdu 30, 8(11) -+ lfdu 31, 8(11) -+ /* Return to caller, restarting the allocation */ -+ Loadglobal(0, caml_last_return_address, 11) -+ addic 0, 0, -16 /* Restart the allocation (4 instructions) */ -+ mtlr 0 -+ /* Say we are back into Caml code */ -+ li 12, 0 -+ Storeglobal(12, caml_last_return_address, 11) -+ /* Deallocate stack frame */ -+ ld 1, 0(1) -+ /* Return */ -+ blr -+ .size .L.caml_call_gc,.-.L.caml_call_gc -+ -+/* Call a C function from Caml */ -+ -+ .globl caml_c_call -+ .type caml_c_call, @function -+ .section ".opd","aw" -+ .align 3 -+caml_c_call: -+ .quad .L.caml_c_call,.TOC.@tocbase -+ .previous -+ .align 2 -+.L.caml_c_call: -+ .cfi_startproc -+ /* Save return address */ -+ mflr 25 -+ .cfi_register lr,25 -+ /* Get ready to call C function (address in 11) */ -+ ld 2, 8(11) -+ ld 11,0(11) -+ mtlr 11 -+ /* Record lowest stack address and return address */ -+ Storeglobal(1, caml_bottom_of_stack, 12) -+ Storeglobal(25, caml_last_return_address, 12) -+ /* Make the exception handler and alloc ptr available to the C code */ -+ Storeglobal(31, caml_young_ptr, 11) -+ Storeglobal(29, caml_exception_pointer, 11) -+ /* Call the function (address in link register) */ -+ blrl -+ /* Restore return address (in 25, preserved by the C function) */ -+ mtlr 25 -+ /* Reload allocation pointer and allocation limit*/ -+ Loadglobal(31, caml_young_ptr, 11) -+ Loadglobal(30, caml_young_limit, 11) -+ /* Say we are back into Caml code */ -+ li 12, 0 -+ Storeglobal(12, caml_last_return_address, 11) -+ /* Return to caller */ -+ blr -+ .cfi_endproc -+ .size .L.caml_c_call,.-.L.caml_c_call -+ -+/* Raise an exception from C */ -+ -+ .globl caml_raise_exception -+ .type caml_raise_exception, @function -+ .section ".opd","aw" -+ .align 3 -+caml_raise_exception: -+ .quad .L.caml_raise_exception,.TOC.@tocbase -+ .previous -+ .align 2 -+.L.caml_raise_exception: -+ /* Reload Caml global registers */ -+ Loadglobal(29, caml_exception_pointer, 11) -+ Loadglobal(31, caml_young_ptr, 11) -+ Loadglobal(30, caml_young_limit, 11) -+ /* Say we are back into Caml code */ -+ li 0, 0 -+ Storeglobal(0, caml_last_return_address, 11) -+ /* Pop trap frame */ -+ ld 0, 8(29) -+ ld 1, 16(29) -+ mtlr 0 -+ ld 2, 24(29) -+ ld 29, 0(29) -+ /* Branch to handler */ -+ blr -+ .size .L.caml_raise_exception,.-.L.caml_raise_exception -+ -+/* Start the Caml program */ -+ -+ .globl caml_start_program -+ .type caml_start_program, @function -+ .section ".opd","aw" -+ .align 3 -+caml_start_program: -+ .quad .L.caml_start_program,.TOC.@tocbase -+ .previous -+ .align 2 -+.L.caml_start_program: -+ Addrglobal(12, caml_program) -+ -+/* Code shared between caml_start_program and caml_callback */ -+.L102: -+ /* Allocate and link stack frame */ -+ mflr 0 -+ std 0, 16(1) -+ stdu 1, -0x190(1) /* 48 + 8*36(regs) + 32(callback) + 32(exc) */ -+ /* Save return address */ -+ /* Save all callee-save registers */ -+ /* GPR 14 ... GPR 31 then FPR 14 ... FPR 31 starting at sp+16 */ -+ addi 11, 1, 48-8 -+ stdu 14, 8(11) -+ stdu 15, 8(11) -+ stdu 16, 8(11) -+ stdu 17, 8(11) -+ stdu 18, 8(11) -+ stdu 19, 8(11) -+ stdu 20, 8(11) -+ stdu 21, 8(11) -+ stdu 22, 8(11) -+ stdu 23, 8(11) -+ stdu 24, 8(11) -+ stdu 25, 8(11) -+ stdu 26, 8(11) -+ stdu 27, 8(11) -+ stdu 28, 8(11) -+ stdu 29, 8(11) -+ stdu 30, 8(11) -+ stdu 31, 8(11) -+ stfdu 14, 8(11) -+ stfdu 15, 8(11) -+ stfdu 16, 8(11) -+ stfdu 17, 8(11) -+ stfdu 18, 8(11) -+ stfdu 19, 8(11) -+ stfdu 20, 8(11) -+ stfdu 21, 8(11) -+ stfdu 22, 8(11) -+ stfdu 23, 8(11) -+ stfdu 24, 8(11) -+ stfdu 25, 8(11) -+ stfdu 26, 8(11) -+ stfdu 27, 8(11) -+ stfdu 28, 8(11) -+ stfdu 29, 8(11) -+ stfdu 30, 8(11) -+ stfdu 31, 8(11) -+ /* Set up a callback link */ -+ Loadglobal(9, caml_bottom_of_stack, 11) -+ Loadglobal(10, caml_last_return_address, 11) -+ Loadglobal(11, caml_gc_regs, 11) -+ std 9, 0x150(1) -+ std 10, 0x158(1) -+ std 11, 0x160(1) -+ /* Build an exception handler to catch exceptions escaping out of Caml */ -+ bl .L103 -+ b .L104 -+.L103: -+ mflr 0 -+ addi 29, 1, 0x170 /* Alignment */ -+ std 0, 8(29) -+ std 1, 16(29) -+ std 2, 24(29) -+ Loadglobal(11, caml_exception_pointer, 11) -+ std 11, 0(29) -+ /* Reload allocation pointers */ -+ Loadglobal(31, caml_young_ptr, 11) -+ Loadglobal(30, caml_young_limit, 11) -+ /* Say we are back into Caml code */ -+ li 0, 0 -+ Storeglobal(0, caml_last_return_address, 11) -+ /* Call the Caml code */ -+ std 2,40(1) -+ ld 2,8(12) -+ ld 12,0(12) -+ mtlr 12 -+.L105: -+ blrl -+ ld 2,40(1) -+ /* Pop the trap frame, restoring caml_exception_pointer */ -+ ld 9, 0x170(1) -+ Storeglobal(9, caml_exception_pointer, 11) -+ /* Pop the callback link, restoring the global variables */ -+.L106: -+ ld 9, 0x150(1) -+ ld 10, 0x158(1) -+ ld 11, 0x160(1) -+ Storeglobal(9, caml_bottom_of_stack, 12) -+ Storeglobal(10, caml_last_return_address, 12) -+ Storeglobal(11, caml_gc_regs, 12) -+ /* Update allocation pointer */ -+ Storeglobal(31, caml_young_ptr, 11) -+ /* Restore callee-save registers */ -+ addi 11, 1, 48-8 -+ ldu 14, 8(11) -+ ldu 15, 8(11) -+ ldu 16, 8(11) -+ ldu 17, 8(11) -+ ldu 18, 8(11) -+ ldu 19, 8(11) -+ ldu 20, 8(11) -+ ldu 21, 8(11) -+ ldu 22, 8(11) -+ ldu 23, 8(11) -+ ldu 24, 8(11) -+ ldu 25, 8(11) -+ ldu 26, 8(11) -+ ldu 27, 8(11) -+ ldu 28, 8(11) -+ ldu 29, 8(11) -+ ldu 30, 8(11) -+ ldu 31, 8(11) -+ lfdu 14, 8(11) -+ lfdu 15, 8(11) -+ lfdu 16, 8(11) -+ lfdu 17, 8(11) -+ lfdu 18, 8(11) -+ lfdu 19, 8(11) -+ lfdu 20, 8(11) -+ lfdu 21, 8(11) -+ lfdu 22, 8(11) -+ lfdu 23, 8(11) -+ lfdu 24, 8(11) -+ lfdu 25, 8(11) -+ lfdu 26, 8(11) -+ lfdu 27, 8(11) -+ lfdu 28, 8(11) -+ lfdu 29, 8(11) -+ lfdu 30, 8(11) -+ lfdu 31, 8(11) -+ /* Return */ -+ ld 1,0(1) -+ /* Reload return address */ -+ ld 0, 16(1) -+ mtlr 0 -+ blr -+ -+ /* The trap handler: */ -+.L104: -+ /* Update caml_exception_pointer */ -+ Storeglobal(29, caml_exception_pointer, 11) -+ /* Encode exception bucket as an exception result and return it */ -+ ori 3, 3, 2 -+ b .L106 -+ .size .L.caml_start_program,.-.L.caml_start_program -+ -+/* Callback from C to Caml */ -+ -+ .globl caml_callback_exn -+ .type caml_callback_exn, @function -+ .section ".opd","aw" -+ .align 3 -+caml_callback_exn: -+ .quad .L.caml_callback_exn,.TOC.@tocbase -+ .previous -+ .align 2 -+.L.caml_callback_exn: -+ /* Initial shuffling of arguments */ -+ mr 0, 3 /* Closure */ -+ mr 3, 4 /* Argument */ -+ mr 4, 0 -+ ld 12, 0(4) /* Code pointer */ -+ b .L102 -+ .size .L.caml_callback_exn,.-.L.caml_callback_exn -+ -+ -+ .globl caml_callback2_exn -+ .type caml_callback2_exn, @function -+ .section ".opd","aw" -+ .align 3 -+caml_callback2_exn: -+ .quad .L.caml_callback2_exn,.TOC.@tocbase -+ .previous -+ .align 2 -+.L.caml_callback2_exn: -+ mr 0, 3 /* Closure */ -+ mr 3, 4 /* First argument */ -+ mr 4, 5 /* Second argument */ -+ mr 5, 0 -+ Addrglobal(12, caml_apply2) -+ b .L102 -+ .size .L.caml_callback2_exn,.-.L.caml_callback2_exn -+ -+ -+ .globl caml_callback3_exn -+ .type caml_callback3_exn, @function -+ .section ".opd","aw" -+ .align 3 -+caml_callback3_exn: -+ .quad .L.caml_callback3_exn,.TOC.@tocbase -+ .previous -+ .align 2 -+.L.caml_callback3_exn: -+ mr 0, 3 /* Closure */ -+ mr 3, 4 /* First argument */ -+ mr 4, 5 /* Second argument */ -+ mr 5, 6 /* Third argument */ -+ mr 6, 0 -+ Addrglobal(12, caml_apply3) -+ b .L102 -+ .size .L.caml_callback3_exn,.-.L.caml_callback3_exn -+ -+/* Frame table */ -+ -+ .section ".data" -+ .globl caml_system__frametable -+ .type caml_system__frametable, @object -+caml_system__frametable: -+ .quad 1 /* one descriptor */ -+ .quad .L105 + 4 /* return address into callback */ -+ .short -1 /* negative size count => use callback link */ -+ .short 0 /* no roots here */ -+ .align 3 -+ -diff --git a/asmrun/stack.h b/asmrun/stack.h -index 57c87fa..756db95 100644 ---- a/asmrun/stack.h -+++ b/asmrun/stack.h -@@ -46,6 +46,15 @@ - #define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) - #endif - -+#ifdef TARGET_power64 -+#define Saved_return_address(sp) *((intnat *)((sp) +16)) -+#define Already_scanned(sp, retaddr) ((retaddr) & 1) -+#define Mark_scanned(sp, retaddr) (Saved_return_address(sp) = (retaddr) | 1) -+#define Mask_already_scanned(retaddr) ((retaddr) & ~1) -+#define Trap_frame_size 0x150 -+#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) -+#endif -+ - #ifdef TARGET_arm - #define Saved_return_address(sp) *((intnat *)((sp) - 4)) - #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -diff --git a/configure b/configure -index e8f8cfd..9bb9e9e 100755 ---- a/configure -+++ b/configure -@@ -698,6 +698,7 @@ case "$host" in - arch=i386; system=macosx - fi;; - i[3456]86-*-gnu*) arch=i386; system=gnu;; -+ powerpc64-*-linux*) arch=power64; model=ppc64; system=elf;; - powerpc*-*-linux*) arch=power; model=ppc; system=elf;; - powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; - powerpc-*-openbsd*) arch=power; model=ppc; system=bsd_elf;; -@@ -781,6 +782,8 @@ case "$arch,$model,$system" in - aspp='gcc -c';; - power,*,bsd*) as='as' - aspp='gcc -c';; -+ power64,*,elf) as='as -u -m ppc64' -+ aspp='gcc -c';; - power,*,rhapsody) as="as -arch $model" - aspp="$bytecc -c";; - sparc,*,solaris) as='as' --- -1.8.3.1 - diff --git a/SOURCES/0006-configure-Allow-user-defined-C-compiler-flags.patch b/SOURCES/0006-configure-Allow-user-defined-C-compiler-flags.patch new file mode 100644 index 0000000..c8f9333 --- /dev/null +++ b/SOURCES/0006-configure-Allow-user-defined-C-compiler-flags.patch @@ -0,0 +1,27 @@ +From 313692e7425fd91917d4e35ad4ade459cb2c1138 Mon Sep 17 00:00:00 2001 +From: "Richard W.M. Jones" +Date: Tue, 29 May 2012 20:44:18 +0100 +Subject: [PATCH 06/12] configure: Allow user defined C compiler flags. + +--- + configure | 4 ++++ + 1 file changed, 4 insertions(+) + +diff --git a/configure b/configure +index e79659954..786f4cdbe 100755 +--- a/configure ++++ b/configure +@@ -2002,6 +2002,10 @@ if $with_fpic; then + echo "#define CAML_WITH_FPIC" >> m.h + fi + ++# Allow user defined C Compiler flags ++bytecccompopts="$bytecccompopts $CFLAGS" ++nativecccompopts="$nativecccompopts $CFLAGS" ++ + # Finish generated files + + cclibs="$cclibs $mathlib" +-- +2.13.2 + diff --git a/SOURCES/0007-Adapt-config.guess-for-RISC-V.patch b/SOURCES/0007-Adapt-config.guess-for-RISC-V.patch new file mode 100644 index 0000000..7611b72 --- /dev/null +++ b/SOURCES/0007-Adapt-config.guess-for-RISC-V.patch @@ -0,0 +1,35 @@ +From 68a8eb8f3bbc254cd5cb685f058bc5b0ef1029e7 Mon Sep 17 00:00:00 2001 +From: Nicolas Ojeda Bar +Date: Tue, 8 Nov 2016 23:56:50 +0100 +Subject: [PATCH 07/12] Adapt config.guess for RISC-V + +--- + config/gnu/config.guess | 5 ++++- + 1 file changed, 4 insertions(+), 1 deletion(-) + +diff --git a/config/gnu/config.guess b/config/gnu/config.guess +index b79252d6b..8335398b2 100755 +--- a/config/gnu/config.guess ++++ b/config/gnu/config.guess +@@ -2,7 +2,7 @@ + # Attempt to guess a canonical system name. + # Copyright 1992-2013 Free Software Foundation, Inc. + +-timestamp='2013-06-10' ++timestamp='2016-10-23' + + # This file is free software; you can redistribute it and/or modify it + # under the terms of the GNU General Public License as published by +@@ -1001,6 +1001,9 @@ EOF + ppcle:Linux:*:*) + echo powerpcle-unknown-linux-${LIBC} + exit ;; ++ riscv*:Linux:*:*) ++ echo ${UNAME_MACHINE}-unknown-linux ++ exit ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux-${LIBC} + exit ;; +-- +2.13.2 + diff --git a/SOURCES/0007-yacc-Use-mkstemp-instead-of-mktemp.patch b/SOURCES/0007-yacc-Use-mkstemp-instead-of-mktemp.patch deleted file mode 100644 index 9c28c1b..0000000 --- a/SOURCES/0007-yacc-Use-mkstemp-instead-of-mktemp.patch +++ /dev/null @@ -1,25 +0,0 @@ -From 4119a66e247a74b559d4df275f223476306440a2 Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Fri, 13 Sep 2013 21:29:58 +0100 -Subject: [PATCH 07/19] yacc: Use mkstemp instead of mktemp. - ---- - yacc/main.c | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/yacc/main.c b/yacc/main.c -index f6cac60..3067000 100644 ---- a/yacc/main.c -+++ b/yacc/main.c -@@ -53,7 +53,7 @@ char *text_file_name; - char *union_file_name; - char *verbose_file_name; - --#if defined(__OpenBSD__) || defined(__NetBSD__) || defined(__FreeBSD__) || defined(__DragonFly__) || (__APPLE__) -+#if defined(__linux__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__FreeBSD__) || defined(__DragonFly__) || (__APPLE__) - #define HAVE_MKSTEMP - #endif - --- -1.8.3.1 - diff --git a/SOURCES/0008-Add-RISC-V-backend-runtime.patch b/SOURCES/0008-Add-RISC-V-backend-runtime.patch new file mode 100644 index 0000000..9a8e815 --- /dev/null +++ b/SOURCES/0008-Add-RISC-V-backend-runtime.patch @@ -0,0 +1,1717 @@ +From d0f08d1cfa01efb02721f7d2e04ce61f38d6d6a7 Mon Sep 17 00:00:00 2001 +From: Nicolas Ojeda Bar +Date: Fri, 4 Nov 2016 20:39:09 +0100 +Subject: [PATCH 08/12] Add RISC-V backend & runtime + +--- + README.adoc | 1 + + asmcomp/riscv/CSE.ml | 36 +++ + asmcomp/riscv/arch.ml | 84 ++++++ + asmcomp/riscv/emit.mlp | 616 ++++++++++++++++++++++++++++++++++++++++++++ + asmcomp/riscv/proc.ml | 301 ++++++++++++++++++++++ + asmcomp/riscv/reload.ml | 16 ++ + asmcomp/riscv/scheduling.ml | 19 ++ + asmcomp/riscv/selection.ml | 85 ++++++ + asmrun/riscv.S | 424 ++++++++++++++++++++++++++++++ + byterun/caml/stack.h | 5 + + configure | 5 +- + 11 files changed, 1591 insertions(+), 1 deletion(-) + create mode 100644 asmcomp/riscv/CSE.ml + create mode 100644 asmcomp/riscv/arch.ml + create mode 100644 asmcomp/riscv/emit.mlp + create mode 100644 asmcomp/riscv/proc.ml + create mode 100644 asmcomp/riscv/reload.ml + create mode 100644 asmcomp/riscv/scheduling.ml + create mode 100644 asmcomp/riscv/selection.ml + create mode 100644 asmrun/riscv.S + +diff --git a/README.adoc b/README.adoc +index fe07edbba..f7d13bc06 100644 +--- a/README.adoc ++++ b/README.adoc +@@ -34,6 +34,7 @@ IA32 (Pentium):: NetBSD, OpenBSD, Solaris 9 + PowerPC:: NetBSD + ARM:: NetBSD + SPARC:: Solaris, Linux, NetBSD ++RISC-V:: Linux + + Other operating systems for the processors above have not been tested, but + the compiler may work under other operating systems with little work. +diff --git a/asmcomp/riscv/CSE.ml b/asmcomp/riscv/CSE.ml +new file mode 100644 +index 000000000..302811a99 +--- /dev/null ++++ b/asmcomp/riscv/CSE.ml +@@ -0,0 +1,36 @@ ++(***********************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2106 Institut National de Recherche en Informatique et *) ++(* en Automatique. All rights reserved. This file is distributed *) ++(* under the terms of the Q Public License version 1.0. *) ++(* *) ++(***********************************************************************) ++ ++(* CSE for the RISC-V *) ++ ++open Arch ++open Mach ++open CSEgen ++ ++class cse = object (_self) ++ ++inherit cse_generic as super ++ ++method! class_of_operation op = ++ match op with ++ | Ispecific(Imultaddf _ | Imultsubf _) -> Op_pure ++ | _ -> super#class_of_operation op ++ ++method! is_cheap_operation op = ++ match op with ++ | Iconst_int n -> n <= 0x7FFn && n >= -0x800n ++ | _ -> false ++ ++end ++ ++let fundecl f = ++ (new cse)#fundecl f +diff --git a/asmcomp/riscv/arch.ml b/asmcomp/riscv/arch.ml +new file mode 100644 +index 000000000..61a38b1dd +--- /dev/null ++++ b/asmcomp/riscv/arch.ml +@@ -0,0 +1,84 @@ ++(***********************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. All rights reserved. This file is distributed *) ++(* under the terms of the Q Public License version 1.0. *) ++(* *) ++(***********************************************************************) ++ ++(* Specific operations for the RISC-V processor *) ++ ++open Format ++ ++(* Machine-specific command-line options *) ++ ++let command_line_options = [] ++ ++(* Specific operations *) ++ ++type specific_operation = ++ | Imultaddf of bool (* multiply, optionally negate, and add *) ++ | Imultsubf of bool (* multiply, optionally negate, and subtract *) ++ ++let spacetime_node_hole_pointer_is_live_before = function ++ | Imultaddf _ | Imultsubf _ -> false ++ ++(* Addressing modes *) ++ ++type addressing_mode = ++ | Iindexed of int (* reg + displ *) ++ ++(* Sizes, endianness *) ++ ++let big_endian = false ++ ++let rv64 = ++ match Config.model with "riscv64" -> true | "riscv32" -> false | _ -> assert false ++ ++let size_addr = if rv64 then 8 else 4 ++let size_int = size_addr ++let size_float = 8 ++ ++let allow_unaligned_access = false ++ ++(* Behavior of division *) ++ ++let division_crashes_on_overflow = false ++ ++(* Operations on addressing modes *) ++ ++let identity_addressing = Iindexed 0 ++ ++let offset_addressing addr delta = ++ match addr with ++ | Iindexed n -> Iindexed(n + delta) ++ ++let num_args_addressing = function ++ | Iindexed _ -> 1 ++ ++(* Printing operations and addressing modes *) ++ ++let print_addressing printreg addr ppf arg = ++ match addr with ++ | Iindexed n -> ++ let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in ++ fprintf ppf "%a%s" printreg arg.(0) idx ++ ++let print_specific_operation printreg op ppf arg = ++ match op with ++ | Imultaddf false -> ++ fprintf ppf "%a *f %a +f %a" ++ printreg arg.(0) printreg arg.(1) printreg arg.(2) ++ | Imultaddf true -> ++ fprintf ppf "-f (%a *f %a +f %a)" ++ printreg arg.(0) printreg arg.(1) printreg arg.(2) ++ | Imultsubf false -> ++ fprintf ppf "%a *f %a -f %a" ++ printreg arg.(0) printreg arg.(1) printreg arg.(2) ++ | Imultsubf true -> ++ fprintf ppf "-f (%a *f %a -f %a)" ++ printreg arg.(0) printreg arg.(1) printreg arg.(2) +diff --git a/asmcomp/riscv/emit.mlp b/asmcomp/riscv/emit.mlp +new file mode 100644 +index 000000000..6d0e3aefd +--- /dev/null ++++ b/asmcomp/riscv/emit.mlp +@@ -0,0 +1,616 @@ ++(***********************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. All rights reserved. This file is distributed *) ++(* under the terms of the Q Public License version 1.0. *) ++(* *) ++(***********************************************************************) ++ ++(* Emission of RISC-V assembly code *) ++ ++open Misc ++open Cmm ++open Arch ++open Proc ++open Reg ++open Mach ++open Linearize ++open Emitaux ++ ++(* Layout of the stack. The stack is kept 16-aligned. *) ++ ++let stack_offset = ref 0 ++ ++let frame_size () = ++ let size = ++ !stack_offset + (* Trap frame, outgoing parameters *) ++ size_int * num_stack_slots.(0) + (* Local int variables *) ++ size_float * num_stack_slots.(1) + (* Local float variables *) ++ (if !contains_calls then size_addr else 0) in (* The return address *) ++ Misc.align size 16 ++ ++let slot_offset loc cls = ++ match loc with ++ | Local n -> ++ if cls = 0 ++ then !stack_offset + num_stack_slots.(1) * size_float + n * size_int ++ else !stack_offset + n * size_float ++ | Incoming n -> frame_size() + n ++ | Outgoing n -> n ++ ++(* Output a symbol *) ++ ++let emit_symbol s = ++ Emitaux.emit_symbol '.' s ++ ++(* Output a label *) ++ ++let label_prefix = "L" ++ ++let emit_label lbl = ++ emit_string label_prefix; emit_int lbl ++ ++(* Section switching *) ++ ++let data_space = ++ ".section .data" ++ ++let code_space = ++ ".section .text" ++ ++let rodata_space = ++ ".section .rodata" ++ ++let reg_tmp1 = phys_reg 21 (* used by the assembler *) ++let reg_tmp2 = phys_reg 22 ++let reg_t2 = phys_reg 16 ++(* let reg_fp = phys_reg 23 *) ++let reg_trap = phys_reg 24 ++let reg_alloc_ptr = phys_reg 25 ++let reg_alloc_lim = phys_reg 26 ++ ++(* Names of instructions that differ in 32 and 64-bit modes *) ++ ++let lg = if rv64 then "ld" else "lw" ++let stg = if rv64 then "sd" else "sw" ++let datag = if rv64 then ".quad" else ".long" ++ ++(* Output a pseudo-register *) ++ ++let emit_reg = function ++ | {loc = Reg r} -> emit_string (register_name r) ++ | _ -> fatal_error "Emit.emit_reg" ++ ++(* Output a stack reference *) ++ ++let emit_stack r = ++ match r.loc with ++ Stack s -> ++ let ofs = slot_offset s (register_class r) in `{emit_int ofs}(sp)` ++ | _ -> fatal_error "Emit.emit_stack" ++ ++(* Record live pointers at call points *) ++ ++let record_frame_label ?label live raise_ dbg = ++ let lbl = ++ match label with ++ | None -> new_label() ++ | Some label -> label ++ in ++ let live_offset = ref [] in ++ Reg.Set.iter ++ (function ++ {typ = Val; loc = Reg r} -> ++ live_offset := (r lsl 1) + 1 :: !live_offset ++ | {typ = Val; loc = Stack s} as reg -> ++ live_offset := slot_offset s (register_class reg) :: !live_offset ++ | {typ = Addr} as r -> ++ Misc.fatal_error ("bad GC root " ^ Reg.name r) ++ | _ -> () ++ ) ++ live; ++ frame_descriptors := ++ { fd_lbl = lbl; ++ fd_frame_size = frame_size(); ++ fd_live_offset = !live_offset; ++ fd_raise = raise_; ++ fd_debuginfo = dbg } :: !frame_descriptors; ++ lbl ++ ++let record_frame ?label live raise_ dbg = ++ let lbl = record_frame_label ?label live raise_ dbg in ++ `{emit_label lbl}:\n` ++ ++(* Record calls to the GC -- we've moved them out of the way *) ++ ++type gc_call = ++ { gc_lbl: label; (* Entry label *) ++ gc_return_lbl: label; (* Where to branch after GC *) ++ gc_frame_lbl: label } (* Label of frame descriptor *) ++ ++let call_gc_sites = ref ([] : gc_call list) ++ ++let emit_call_gc gc = ++ `{emit_label gc.gc_lbl}:\n`; ++ ` call {emit_symbol "caml_call_gc"}\n`; ++ `{emit_label gc.gc_frame_lbl}:\n`; ++ ` j {emit_label gc.gc_return_lbl}\n` ++ ++(* Record calls to caml_ml_array_bound_error. ++ In debug mode, we maintain one call to caml_ml_array_bound_error ++ per bound check site. Otherwise, we can share a single call. *) ++ ++type bound_error_call = ++ { bd_lbl: label; (* Entry label *) ++ bd_frame_lbl: label } (* Label of frame descriptor *) ++ ++let bound_error_sites = ref ([] : bound_error_call list) ++ ++let bound_error_label ?label dbg = ++ if !Clflags.debug || !bound_error_sites = [] then begin ++ let lbl_bound_error = new_label() in ++ let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in ++ bound_error_sites := ++ { bd_lbl = lbl_bound_error; ++ bd_frame_lbl = lbl_frame } :: !bound_error_sites; ++ lbl_bound_error ++ end else ++ let bd = List.hd !bound_error_sites in ++ bd.bd_lbl ++ ++let emit_call_bound_error bd = ++ `{emit_label bd.bd_lbl}:\n`; ++ ` call {emit_symbol "caml_ml_array_bound_error"}\n`; ++ `{emit_label bd.bd_frame_lbl}:\n` ++ ++(* Record floating-point literals *) ++ ++let float_literals = ref ([] : (int64 * int) list) ++ ++(* Names for various instructions *) ++ ++let name_for_intop = function ++ | Iadd -> "add" ++ | Isub -> "sub" ++ | Imul -> "mul" ++ | Imulh -> "mulh" ++ | Idiv -> "div" ++ | Iand -> "and" ++ | Ior -> "or" ++ | Ixor -> "xor" ++ | Ilsl -> "sll" ++ | Ilsr -> "srl" ++ | Iasr -> "sra" ++ | Imod -> "rem" ++ | _ -> fatal_error "Emit.Intop" ++ ++let name_for_intop_imm = function ++ | Iadd -> "addi" ++ | Iand -> "andi" ++ | Ior -> "ori" ++ | Ixor -> "xori" ++ | Ilsl -> "slli" ++ | Ilsr -> "srli" ++ | Iasr -> "srai" ++ | _ -> fatal_error "Emit.Intop_imm" ++ ++let name_for_floatop1 = function ++ | Inegf -> "fneg.d" ++ | Iabsf -> "fabs.d" ++ | _ -> fatal_error "Emit.Iopf1" ++ ++let name_for_floatop2 = function ++ | Iaddf -> "fadd.d" ++ | Isubf -> "fsub.d" ++ | Imulf -> "fmul.d" ++ | Idivf -> "fdiv.d" ++ | _ -> fatal_error "Emit.Iopf2" ++ ++let name_for_specific = function ++ | Imultaddf false -> "fmadd.d" ++ | Imultaddf true -> "fnmadd.d" ++ | Imultsubf false -> "fmsub.d" ++ | Imultsubf true -> "fnmsub.d" ++ ++(* Name of current function *) ++let function_name = ref "" ++(* Entry point for tail recursive calls *) ++let tailrec_entry_point = ref 0 ++ ++(* Output the assembly code for an instruction *) ++ ++let emit_instr i = ++ match i.desc with ++ Lend -> () ++ | Lop(Imove | Ispill | Ireload) -> ++ let src = i.arg.(0) and dst = i.res.(0) in ++ if src.loc <> dst.loc then begin ++ match (src, dst) with ++ | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ++ ` mv {emit_reg dst}, {emit_reg src}\n` ++ | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> ++ ` fmv.d {emit_reg dst}, {emit_reg src}\n` ++ | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} -> ++ ` {emit_string stg} {emit_reg src}, {emit_stack dst}\n` ++ | {loc = Reg _; typ = Float}, {loc = Stack _} -> ++ ` fsd {emit_reg src}, {emit_stack dst}\n` ++ | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _ } -> ++ ` {emit_string lg} {emit_reg dst}, {emit_stack src}\n` ++ | {loc = Stack _; typ = Float}, {loc = Reg _} -> ++ ` fld {emit_reg dst}, {emit_stack src}\n` ++ | _ -> ++ fatal_error "Emit: Imove" ++ end ++ | Lop(Iconst_int n) -> ++ ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` ++ | Lop(Iconst_float f) -> ++ let lbl = new_label() in ++ float_literals := (f, lbl) :: !float_literals; ++ ` fld {emit_reg i.res.(0)}, {emit_label lbl}, {emit_reg reg_tmp1}\n` ++ | Lop(Iconst_symbol s) -> ++ ` la {emit_reg i.res.(0)}, {emit_symbol s}\n` ++ | Lop(Icall_ind {label_after = label}) -> ++ ` jalr {emit_reg i.arg.(0)}\n`; ++ record_frame ~label i.live false i.dbg ++ | Lop(Icall_imm {func; label_after = label}) -> ++ ` call {emit_symbol func}\n`; ++ record_frame ~label i.live false i.dbg ++ | Lop(Itailcall_ind {label_after = _}) -> ++ let n = frame_size() in ++ if !contains_calls then ++ ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n`; ++ if n > 0 then ++ ` addi sp, sp, {emit_int n}\n`; ++ ` jr {emit_reg i.arg.(0)}\n` ++ | Lop(Itailcall_imm {func; label_after = _}) -> ++ if func = !function_name then begin ++ ` j {emit_label !tailrec_entry_point}\n` ++ end else begin ++ let n = frame_size() in ++ if !contains_calls then ++ ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n`; ++ if n > 0 then ++ ` addi sp, sp, {emit_int n}\n`; ++ ` tail {emit_symbol func}\n` ++ end ++ | Lop(Iextcall{func; alloc = true; label_after = label}) -> ++ ` la {emit_reg reg_t2}, {emit_symbol func}\n`; ++ ` call {emit_symbol "caml_c_call"}\n`; ++ record_frame ~label i.live false i.dbg ++ | Lop(Iextcall{func; alloc = false; label_after = _}) -> ++ ` call {emit_symbol func}\n` ++ | Lop(Istackoffset n) -> ++ assert (n mod 16 = 0); ++ ` addi sp, sp, {emit_int (-n)}\n`; ++ stack_offset := !stack_offset + n ++ | Lop(Iload(Single, Iindexed ofs)) -> ++ ` flw {emit_reg i.res.(0)}, {emit_int ofs}({emit_reg i.arg.(0)})\n`; ++ ` fcvt.d.s {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` ++ | Lop(Iload(chunk, Iindexed ofs)) -> ++ let instr = ++ match chunk with ++ | Byte_unsigned -> "lbu" ++ | Byte_signed -> "lb" ++ | Sixteen_unsigned -> "lhu" ++ | Sixteen_signed -> "lh" ++ | Thirtytwo_unsigned -> if rv64 then "lwu" else "lw" ++ | Thirtytwo_signed -> "lw" ++ | Word_int | Word_val -> lg ++ | Single -> assert false ++ | Double | Double_u -> "fld" ++ in ++ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_int ofs}({emit_reg i.arg.(0)})\n` ++ | Lop(Istore(Single, Iindexed ofs, _)) -> ++ ` fmv.x.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}\n`; ++ ` fcvt.s.d {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}\n`; ++ ` fsw {emit_reg i.arg.(0)}, {emit_int ofs}({emit_reg i.arg.(1)})\n`; ++ ` fmv.d.x {emit_reg i.arg.(0)}, {emit_reg reg_tmp1}\n` ++ | Lop(Istore(chunk, Iindexed ofs, _)) -> ++ let instr = ++ match chunk with ++ | Byte_unsigned | Byte_signed -> "sb" ++ | Sixteen_unsigned | Sixteen_signed -> "sh" ++ | Thirtytwo_unsigned | Thirtytwo_signed -> "sw" ++ | Word_int | Word_val -> stg ++ | Single -> assert false ++ | Double | Double_u -> "fsd" ++ in ++ ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int ofs}({emit_reg i.arg.(1)})\n` ++ | Lop(Ialloc {words = n; label_after_call_gc = label; _}) -> ++ let lbl_frame_lbl = record_frame_label ?label i.live false i.dbg in ++ let lbl_redo = new_label () in ++ let lbl_call_gc = new_label () in ++ `{emit_label lbl_redo}:\n`; ++ ` addi {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, -{emit_int n}\n`; ++ ` addi {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, {emit_int size_addr}\n`; ++ ` bltu {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_lim}, {emit_label lbl_call_gc}\n`; ++ call_gc_sites := ++ { gc_lbl = lbl_call_gc; ++ gc_return_lbl = lbl_redo; ++ gc_frame_lbl = lbl_frame_lbl } :: !call_gc_sites ++ | Lop(Iintop(Icomp cmp)) -> ++ begin match cmp with ++ | Isigned Clt -> ++ ` slt {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` ++ | Isigned Cge -> ++ ` slt {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ++ ` xori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`; ++ | Isigned Cgt -> ++ ` slt {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` ++ | Isigned Cle -> ++ ` slt {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; ++ ` xori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`; ++ | Isigned Ceq | Iunsigned Ceq -> ++ ` sub {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ++ ` seqz {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` ++ | Isigned Cne | Iunsigned Cne -> ++ ` sub {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ++ ` snez {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` ++ | Iunsigned Clt -> ++ ` sltu {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` ++ | Iunsigned Cge -> ++ ` sltu {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ++ ` xori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`; ++ | Iunsigned Cgt -> ++ ` sltu {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` ++ | Iunsigned Cle -> ++ ` sltu {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; ++ ` xori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`; ++ end ++ | Lop(Iintop (Icheckbound {label_after_error = label; _})) -> ++ let lbl = bound_error_label ?label i.dbg in ++ ` bleu {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n` ++ | Lop(Iintop op) -> ++ let instr = name_for_intop op in ++ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` ++ | Lop(Iintop_imm(Isub, n)) -> ++ ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n` ++ | Lop(Iintop_imm(Icomp _, _)) -> ++ fatal_error "Emit.emit_instr (Iintop_imm (Icomp _, _))" ++ | Lop(Iintop_imm(Icheckbound {label_after_error = label; _}, n)) -> ++ let lbl = bound_error_label ?label i.dbg in ++ ` li {emit_reg reg_tmp1}, {emit_int n}\n`; ++ ` bleu {emit_reg i.arg.(0)}, {emit_reg reg_tmp1}, {emit_label lbl}\n` ++ | Lop(Iintop_imm(op, n)) -> ++ let instr = name_for_intop_imm op in ++ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n` ++ | Lop(Inegf | Iabsf as op) -> ++ let instr = name_for_floatop1 op in ++ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` ++ | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> ++ let instr = name_for_floatop2 op in ++ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` ++ | Lop(Ifloatofint) -> ++ let name = if rv64 then "fcvt.d.l" else "fcvt.d.w" in ++ ` {emit_string name} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` ++ | Lop(Iintoffloat) -> ++ let name = if rv64 then "fcvt.l.d" else "fcvt.w.d" in ++ ` {emit_string name} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` ++ | Lop(Ispecific sop) -> ++ let instr = name_for_specific sop in ++ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` ++ | Lreloadretaddr -> ++ let n = frame_size () in ++ ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n` ++ | Lreturn -> ++ let n = frame_size() in ++ if n > 0 then ++ ` addi sp, sp, {emit_int n}\n`; ++ ` ret\n` ++ | Llabel lbl -> ++ `{emit_label lbl}:\n` ++ | Lbranch lbl -> ++ ` j {emit_label lbl}\n` ++ | Lcondbranch(tst, lbl) -> ++ begin match tst with ++ | Itruetest -> ++ ` bnez {emit_reg i.arg.(0)}, {emit_label lbl}\n` ++ | Ifalsetest -> ++ ` beqz {emit_reg i.arg.(0)}, {emit_label lbl}\n` ++ | Iinttest cmp -> ++ let name = match cmp with ++ | Iunsigned Ceq | Isigned Ceq -> "beq" ++ | Iunsigned Cne | Isigned Cne -> "bne" ++ | Iunsigned Cle -> "bleu" | Isigned Cle -> "ble" ++ | Iunsigned Cge -> "bgeu" | Isigned Cge -> "bge" ++ | Iunsigned Clt -> "bltu" | Isigned Clt -> "blt" ++ | Iunsigned Cgt -> "bgtu" | Isigned Cgt -> "bgt" ++ in ++ ` {emit_string name} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n` ++ | Iinttest_imm _ -> ++ fatal_error "Emit.emit_instr (Iinttest_imm _)" ++ | Ifloattest(cmp, neg) -> ++ let neg = match cmp with ++ | Ceq -> ` feq.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; neg ++ | Cne -> ` feq.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; not neg ++ | Clt -> ` flt.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; neg ++ | Cgt -> ` flt.d {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; neg ++ | Cle -> ` fle.d {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; neg ++ | Cge -> ` fle.d {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; neg ++ in ++ if neg then ++ ` beqz {emit_reg reg_tmp1}, {emit_label lbl}\n` ++ else ++ ` bnez {emit_reg reg_tmp1}, {emit_label lbl}\n` ++ | Ioddtest -> ++ ` andi {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, 1\n`; ++ ` bnez {emit_reg reg_tmp1}, {emit_label lbl}\n` ++ | Ieventest -> ++ ` andi {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, 1\n`; ++ ` beqz {emit_reg reg_tmp1}, {emit_label lbl}\n` ++ end ++ | Lcondbranch3(lbl0, lbl1, lbl2) -> ++ ` addi {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, -1\n`; ++ begin match lbl0 with ++ | None -> () ++ | Some lbl -> ` bltz {emit_reg reg_tmp1}, {emit_label lbl}\n` ++ end; ++ begin match lbl1 with ++ | None -> () ++ | Some lbl -> ` beqz {emit_reg reg_tmp1}, {emit_label lbl}\n` ++ end; ++ begin match lbl2 with ++ | None -> () ++ | Some lbl -> ` bgtz {emit_reg reg_tmp1}, {emit_label lbl}\n` ++ end ++ | Lswitch jumptbl -> (* FIXME FIXME ? *) ++ let lbl = new_label() in ++ ` la {emit_reg reg_tmp1}, {emit_label lbl}\n`; ++ ` slli {emit_reg reg_tmp2}, {emit_reg i.arg.(0)}, 2\n`; ++ ` add {emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_reg reg_tmp2}\n`; ++ ` jr {emit_reg reg_tmp1}\n`; ++ `{emit_label lbl}:\n`; ++ for i = 0 to Array.length jumptbl - 1 do ++ ` j {emit_label jumptbl.(i)}\n` ++ done ++ | Lsetuptrap lbl -> ++ ` addi sp, sp, -16\n`; ++ ` jal {emit_label lbl}\n` ++ | Lpushtrap -> ++ stack_offset := !stack_offset + 16; ++ ` {emit_string stg} ra, {emit_int size_addr}(sp)\n`; ++ ` {emit_string stg} {emit_reg reg_trap}, 0(sp)\n`; ++ ` mv {emit_reg reg_trap}, sp\n` ++ | Lpoptrap -> ++ ` {emit_string lg} {emit_reg reg_trap}, 0(sp)\n`; ++ ` addi sp, sp, 16\n`; ++ stack_offset := !stack_offset - 16 ++ | Lraise k -> ++ begin match !Clflags.debug, k with ++ | true, Cmm.Raise_withtrace -> ++ ` call {emit_symbol "caml_raise_exn"}\n`; ++ record_frame Reg.Set.empty true i.dbg ++ | false, _ ++ | true, Cmm.Raise_notrace -> ++ ` mv sp, {emit_reg reg_trap}\n`; ++ ` {emit_string lg} {emit_reg reg_tmp1}, {emit_int size_addr}(sp)\n`; ++ ` {emit_string lg} {emit_reg reg_trap}, 0(sp)\n`; ++ ` addi sp, sp, 16\n`; ++ ` jalr {emit_reg reg_tmp1}\n` ++ end ++ ++(* Emit a sequence of instructions *) ++ ++let rec emit_all = function ++ | {desc = Lend} -> () | i -> emit_instr i; emit_all i.next ++ ++(* Emission of a function declaration *) ++ ++let fundecl fundecl = ++ function_name := fundecl.fun_name; ++ tailrec_entry_point := new_label(); ++ stack_offset := 0; ++ call_gc_sites := []; ++ bound_error_sites := []; ++ float_literals := []; ++ ` .globl {emit_symbol fundecl.fun_name}\n`; ++ ` .type {emit_symbol fundecl.fun_name}, @function\n`; ++ ` {emit_string code_space}\n`; ++ ` .align 2\n`; ++ `{emit_symbol fundecl.fun_name}:\n`; ++ let n = frame_size() in ++ if n > 0 then ++ ` addi sp, sp, {emit_int(-n)}\n`; ++ if !contains_calls then ++ ` {emit_string stg} ra, {emit_int(n - size_addr)}(sp)\n`; ++ `{emit_label !tailrec_entry_point}:\n`; ++ emit_all fundecl.fun_body; ++ List.iter emit_call_gc !call_gc_sites; ++ List.iter emit_call_bound_error !bound_error_sites; ++ ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`; ++ (* Emit the float literals *) ++ if !float_literals <> [] then begin ++ ` {emit_string rodata_space}\n`; ++ ` .align 3\n`; ++ List.iter ++ (fun (f, lbl) -> ++ `{emit_label lbl}:\n`; ++ if rv64 ++ then emit_float64_directive ".quad" f ++ else emit_float64_split_directive ".long" f) ++ !float_literals; ++ end ++ ++(* Emission of data *) ++ ++let declare_global_data s = ++ ` .globl {emit_symbol s}\n`; ++ ` .type {emit_symbol s}, @object\n` ++ ++let emit_item = function ++ | Cglobal_symbol s -> ++ declare_global_data s ++ | Cdefine_symbol s -> ++ `{emit_symbol s}:\n`; ++ | Cint8 n -> ++ ` .byte {emit_int n}\n` ++ | Cint16 n -> ++ ` .short {emit_int n}\n` ++ | Cint32 n -> ++ ` .long {emit_nativeint n}\n` ++ | Cint n -> ++ ` {emit_string datag} {emit_nativeint n}\n` ++ | Csingle f -> ++ emit_float32_directive ".long" (Int32.bits_of_float f) ++ | Cdouble f -> ++ if rv64 ++ then emit_float64_directive ".quad" (Int64.bits_of_float f) ++ else emit_float64_split_directive ".long" (Int64.bits_of_float f) ++ | Csymbol_address s -> ++ ` {emit_string datag} {emit_symbol s}\n` ++ | Cstring s -> ++ emit_bytes_directive " .byte " s ++ | Cskip n -> ++ if n > 0 then ` .space {emit_int n}\n` ++ | Calign n -> ++ ` .align {emit_int (Misc.log2 n)}\n` ++ ++let data l = ++ ` {emit_string data_space}\n`; ++ List.iter emit_item l ++ ++(* Beginning / end of an assembly file *) ++ ++let begin_assembly() = ++ (* Emit the beginning of the segments *) ++ let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ++ ` {emit_string data_space}\n`; ++ declare_global_data lbl_begin; ++ `{emit_symbol lbl_begin}:\n`; ++ let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ++ ` {emit_string code_space}\n`; ++ declare_global_data lbl_begin; ++ `{emit_symbol lbl_begin}:\n` ++ ++let end_assembly() = ++ ` {emit_string code_space}\n`; ++ let lbl_end = Compilenv.make_symbol (Some "code_end") in ++ declare_global_data lbl_end; ++ `{emit_symbol lbl_end}:\n`; ++ ` .long 0\n`; ++ ` {emit_string data_space}\n`; ++ let lbl_end = Compilenv.make_symbol (Some "data_end") in ++ declare_global_data lbl_end; ++ `{emit_symbol lbl_end}:\n`; ++ ` {emit_string datag} 0\n`; ++ (* Emit the frame descriptors *) ++ ` {emit_string rodata_space}\n`; ++ let lbl = Compilenv.make_symbol (Some "frametable") in ++ declare_global_data lbl; ++ `{emit_symbol lbl}:\n`; ++ emit_frames ++ { efa_code_label = (fun l -> ` {emit_string datag} {emit_label l}\n`); ++ efa_data_label = (fun l -> ` {emit_string datag} {emit_label l}\n`); ++ efa_16 = (fun n -> ` .short {emit_int n}\n`); ++ efa_32 = (fun n -> ` .long {emit_int32 n}\n`); ++ efa_word = (fun n -> ` {emit_string datag} {emit_int n}\n`); ++ efa_align = (fun n -> ` .align {emit_int (Misc.log2 n)}\n`); ++ efa_label_rel = (fun lbl ofs -> ++ ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); ++ efa_def_label = (fun l -> `{emit_label l}:\n`); ++ efa_string = (fun s -> emit_bytes_directive " .byte " (s ^ "\000")) ++ } +diff --git a/asmcomp/riscv/proc.ml b/asmcomp/riscv/proc.ml +new file mode 100644 +index 000000000..c0b0dcdb8 +--- /dev/null ++++ b/asmcomp/riscv/proc.ml +@@ -0,0 +1,301 @@ ++(***********************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. All rights reserved. This file is distributed *) ++(* under the terms of the Q Public License version 1.0. *) ++(* *) ++(***********************************************************************) ++ ++(* Description of the RISC-V *) ++ ++open Misc ++open Cmm ++open Reg ++open Arch ++open Mach ++ ++(* Instruction selection *) ++ ++let word_addressed = false ++ ++(* Registers available for register allocation *) ++ ++(* Integer register map: ++ zero always zero ++ ra return address ++ sp, gp, tp stack pointer, global pointer, thread pointer (preserved by C) ++ a0 - a7 0 - 7 arguments/results ++ s2 - s9 8 - 15 arguments/results (preserved by C) ++ t2 - t6 16 - 20 temporary ++ t0 21 temporary (used by assembler) ++ t1 22 temporary (reserved for code gen) ++ s0 23 frame pointer (preserved by C) ++ s1 24 trap pointer (preserved by C) ++ s10 25 allocation pointer (preserved by C) ++ s11 26 allocation limit (preserved by C) ++ Floating-point register map: ++ ft0 - ft7 100 - 107 temporary ++ fs0 - fs1 108 - 109 general purpose (preserved by C) ++ fa0 - fa7 110 - 117 arguments/results ++ fs2 - fs9 118 - 125 arguments/results (preserved by C) ++ fs10 - fs11 126 - 127 general purpose (preserved by C) ++ ft8 - ft11 128 - 131 temporary ++*) ++ ++let int_reg_name = ++ [| "a0"; "a1"; "a2"; "a3"; "a4"; "a5"; "a6"; "a7"; ++ "s2"; "s3"; "s4"; "s5"; "s6"; "s7"; "s8"; "s9"; ++ "t2"; "t3"; "t4"; "t5"; "t6"; ++ "t0"; "t1"; ++ "s0"; "s1"; "s10"; "s11" |] ++ ++let float_reg_name = ++ [| "ft0"; "ft1"; "ft2"; "ft3"; "ft4"; "ft5"; "ft6"; "ft7"; ++ "fs0"; "fs1"; ++ "fa0"; "fa1"; "fa2"; "fa3"; "fa4"; "fa5"; "fa6"; "fa7"; ++ "fs2"; "fs3"; "fs4"; "fs5"; "fs6"; "fs7"; "fs8"; "fs9"; "fs10"; "fs11"; ++ "ft8"; "ft9"; "ft10"; "ft11" |] ++ ++let num_register_classes = 2 ++ ++let register_class r = ++ match r.typ with ++ | Val | Int | Addr -> 0 ++ | Float -> 1 ++ ++let num_available_registers = [| 21; 32 |] ++ ++let first_available_register = [| 0; 100 |] ++ ++let register_name r = ++ if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) ++ ++let rotate_registers = true ++ ++(* Representation of hard registers by pseudo-registers *) ++ ++let hard_int_reg = ++ let v = Array.make 27 Reg.dummy in ++ for i = 0 to 26 do ++ v.(i) <- Reg.at_location Int (Reg i) ++ done; ++ v ++ ++let hard_float_reg = ++ let v = Array.make 32 Reg.dummy in ++ for i = 0 to 31 do ++ v.(i) <- Reg.at_location Float (Reg(100 + i)) ++ done; ++ v ++ ++let all_phys_regs = ++ Array.append hard_int_reg hard_float_reg ++ ++let phys_reg n = ++ if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) ++ ++let stack_slot slot ty = ++ Reg.at_location ty (Stack slot) ++ ++(* Calling conventions *) ++ ++let calling_conventions ++ first_int last_int first_float last_float make_stack arg = ++ let loc = Array.make (Array.length arg) Reg.dummy in ++ let int = ref first_int in ++ let float = ref first_float in ++ let ofs = ref 0 in ++ for i = 0 to Array.length arg - 1 do ++ match arg.(i).typ with ++ | Val | Int | Addr as ty -> ++ if !int <= last_int then begin ++ loc.(i) <- phys_reg !int; ++ incr int ++ end else begin ++ loc.(i) <- stack_slot (make_stack !ofs) ty; ++ ofs := !ofs + size_int ++ end ++ | Float -> ++ if !float <= last_float then begin ++ loc.(i) <- phys_reg !float; ++ incr float ++ end else begin ++ loc.(i) <- stack_slot (make_stack !ofs) Float; ++ ofs := !ofs + size_float ++ end ++ done; ++ (loc, Misc.align !ofs 16) (* Keep stack 16-aligned. *) ++ ++let incoming ofs = Incoming ofs ++let outgoing ofs = Outgoing ofs ++let not_supported _ = fatal_error "Proc.loc_results: cannot call" ++ ++let max_arguments_for_tailcalls = 16 ++ ++let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) ++ ++(* OCaml calling convention: ++ first integer args in a0 .. a7, s2 .. s9 ++ first float args in fa0 .. fa7, fs2 .. fs9 ++ remaining args on stack. ++ Return values in a0 .. a7, s2 .. s9 or fa0 .. fa7, fs2 .. fs9. *) ++ ++let single_regs arg = Array.map (fun arg -> [| arg |]) arg ++let ensure_single_regs res = ++ Array.map (function ++ | [| res |] -> res ++ | _ -> failwith "proc.ensure_single_regs" ++ ) res ++ ++let loc_arguments arg = ++ calling_conventions 0 15 110 125 outgoing arg ++ ++let loc_parameters arg = ++ let (loc, _ofs) = ++ calling_conventions 0 15 110 125 incoming arg ++ in ++ loc ++ ++let loc_results res = ++ let (loc, _ofs) = ++ calling_conventions 0 15 110 125 not_supported res ++ in ++ loc ++ ++(* C calling convention: ++ first integer args in a0 .. a7 ++ first float args in fa0 .. fa7 ++ remaining args on stack. ++ Return values in a0 .. a1 or fa0 .. fa1. *) ++ ++let external_calling_conventions ++ first_int last_int first_float last_float make_stack arg = ++ let loc = Array.make (Array.length arg) [| Reg.dummy |] in ++ let int = ref first_int in ++ let float = ref first_float in ++ let ofs = ref 0 in ++ for i = 0 to Array.length arg - 1 do ++ match arg.(i) with ++ | [| arg |] -> ++ begin match arg.typ with ++ | Val | Int | Addr as ty -> ++ if !int <= last_int then begin ++ loc.(i) <- [| phys_reg !int |]; ++ incr int; ++ incr float; ++ end else begin ++ loc.(i) <- [| stack_slot (make_stack !ofs) ty |]; ++ ofs := !ofs + size_int ++ end ++ | Float -> ++ if !float <= last_float then begin ++ loc.(i) <- [| phys_reg !float |]; ++ incr float; ++ incr int; ++ end else begin ++ loc.(i) <- [| stack_slot (make_stack !ofs) Float |]; ++ ofs := !ofs + size_float ++ end ++ end ++ | [| arg1; arg2 |] -> ++ (* Passing of 64-bit quantities to external functions on 32-bit ++ platform. *) ++ assert (size_int = 4); ++ begin match arg1.typ, arg2.typ with ++ | Int, Int -> ++ int := Misc.align !int 2; ++ if !int <= last_int - 1 then begin ++ let reg_lower = phys_reg !int in ++ let reg_upper = phys_reg (!int + 1) in ++ loc.(i) <- [| reg_lower; reg_upper |]; ++ int := !int + 2 ++ end else begin ++ let size_int64 = 8 in ++ ofs := Misc.align !ofs size_int64; ++ let ofs_lower = !ofs in ++ let ofs_upper = !ofs + size_int in ++ let stack_lower = stack_slot (make_stack ofs_lower) Int in ++ let stack_upper = stack_slot (make_stack ofs_upper) Int in ++ loc.(i) <- [| stack_lower; stack_upper |]; ++ ofs := !ofs + size_int64 ++ end ++ | _ -> ++ let f = function Int -> "I" | Addr -> "A" | Val -> "V" | Float -> "F" in ++ fatal_error (Printf.sprintf "Proc.calling_conventions: bad register \ ++ type(s) for multi-register argument: %s, %s" ++ (f arg1.typ) (f arg2.typ)) ++ end ++ | _ -> ++ fatal_error "Proc.calling_conventions: bad number of register for \ ++ multi-register argument" ++ done; ++ (loc, Misc.align !ofs 16) (* Keep stack 16-aligned. *) ++ ++let loc_external_arguments arg = ++ external_calling_conventions 0 7 110 117 outgoing arg ++ ++let loc_external_results res = ++ let (loc, _ofs) = ++ external_calling_conventions 0 1 110 111 not_supported (single_regs res) ++ in ++ ensure_single_regs loc ++ ++(* Exceptions are in GPR 3 *) ++ ++let loc_exn_bucket = phys_reg 0 ++ ++(* Volatile registers: none *) ++ ++let regs_are_volatile _ = false ++ ++(* Registers destroyed by operations *) ++ ++let destroyed_at_c_call = ++ Array.of_list(List.map phys_reg ++ [0; 1; 2; 3; 4; 5; 6; 7; 16; 17; 18; 19; 20; (* 21; 22; *) ++ 100; 101; 102; 103; 104; 105; 106; 107; 110; 111; 112; 113; 114; 115; 116; ++ 117; 128; 129; 130; 131]) ++ ++let destroyed_at_oper = function ++ | Iop(Icall_ind _ | Icall_imm _ | Iextcall{alloc = true; _}) -> all_phys_regs ++ | Iop(Iextcall{alloc = false; _}) -> destroyed_at_c_call ++ | _ -> [||] ++ ++let destroyed_at_raise = all_phys_regs ++ ++(* Maximal register pressure *) ++ ++let safe_register_pressure = function ++ | Iextcall _ -> 15 ++ | _ -> 21 ++ ++let max_register_pressure = function ++ | Iextcall _ -> [| 15; 18 |] ++ | _ -> [| 21; 30 |] ++ ++(* Pure operations (without any side effect besides updating their result ++ registers). *) ++ ++let op_is_pure = function ++ | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ ++ | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ ++ | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false ++ | Ispecific(Imultaddf _ | Imultsubf _) -> true ++ | _ -> true ++ ++(* Layout of the stack *) ++ ++let num_stack_slots = [| 0; 0 |] ++let contains_calls = ref false ++ ++(* Calling the assembler *) ++ ++let assemble_file infile outfile = ++ Ccomp.command ++ (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) ++ ++let init () = () +diff --git a/asmcomp/riscv/reload.ml b/asmcomp/riscv/reload.ml +new file mode 100644 +index 000000000..85b970342 +--- /dev/null ++++ b/asmcomp/riscv/reload.ml +@@ -0,0 +1,16 @@ ++(***********************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. All rights reserved. This file is distributed *) ++(* under the terms of the Q Public License version 1.0. *) ++(* *) ++(***********************************************************************) ++ ++(* Reloading for the RISC-V *) ++ ++let fundecl f = ++ (new Reloadgen.reload_generic)#fundecl f +diff --git a/asmcomp/riscv/scheduling.ml b/asmcomp/riscv/scheduling.ml +new file mode 100644 +index 000000000..e436be1cc +--- /dev/null ++++ b/asmcomp/riscv/scheduling.ml +@@ -0,0 +1,19 @@ ++(***********************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. All rights reserved. This file is distributed *) ++(* under the terms of the Q Public License version 1.0. *) ++(* *) ++(***********************************************************************) ++ ++(* Instruction scheduling for the RISC-V *) ++ ++let _ = let module M = Schedgen in () (* to create a dependency *) ++ ++(* Scheduling is turned off. *) ++ ++let fundecl f = f +diff --git a/asmcomp/riscv/selection.ml b/asmcomp/riscv/selection.ml +new file mode 100644 +index 000000000..60ec5cb4e +--- /dev/null ++++ b/asmcomp/riscv/selection.ml +@@ -0,0 +1,85 @@ ++(***********************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Nicolas Ojeda Bar *) ++(* *) ++(* Copyright 2016 Institut National de Recherche en Informatique et *) ++(* en Automatique. All rights reserved. This file is distributed *) ++(* under the terms of the Q Public License version 1.0. *) ++(* *) ++(***********************************************************************) ++ ++(* Instruction selection for the RISC-V processor *) ++ ++open Cmm ++open Arch ++open Mach ++ ++(* Instruction selection *) ++ ++class selector = object (self) ++ ++inherit Selectgen.selector_generic as super ++ ++method is_immediate n = (n <= 0x7FF) && (n >= -0x800) ++ ++method select_addressing _ = function ++ | Cop(Cadda, [arg; Cconst_int n]) when self#is_immediate n -> ++ (Iindexed n, arg) ++ | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) when self#is_immediate n -> ++ (Iindexed n, Cop(Caddi, [arg1; arg2])) ++ | arg -> ++ (Iindexed 0, arg) ++ ++method! select_operation op args = ++ match (op, args) with ++ (* RISC-V does not support immediate operands for multiply high *) ++ | (Cmulhi, _) -> (Iintop Imulh, args) ++ (* The and, or and xor instructions have a different range of immediate ++ operands than the other instructions *) ++ | (Cand, _) -> self#select_logical Iand args ++ | (Cor, _) -> self#select_logical Ior args ++ | (Cxor, _) -> self#select_logical Ixor args ++ (* Recognize (neg-)mult-add and (neg-)mult-sub instructions *) ++ | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) ++ | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> ++ (Ispecific (Imultaddf false), [arg1; arg2; arg3]) ++ | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> ++ (Ispecific (Imultsubf false), [arg1; arg2; arg3]) ++ | (Cnegf, [Cop(Csubf, [Cop(Cmulf, [arg1; arg2]); arg3])]) -> ++ (Ispecific (Imultsubf true), [arg1; arg2; arg3]) ++ | (Cnegf, [Cop(Caddf, [Cop(Cmulf, [arg1; arg2]); arg3])]) -> ++ (Ispecific (Imultaddf true), [arg1; arg2; arg3]) ++ (* RISC-V does not support immediate operands for comparison operators *) ++ | (Ccmpi comp, args) -> (Iintop(Icomp (Isigned comp)), args) ++ | (Ccmpa comp, args) -> (Iintop(Icomp (Iunsigned comp)), args) ++ | (Cmuli, _) -> (Iintop Imul, args) ++ | _ -> ++ super#select_operation op args ++ ++method select_logical op = function ++ | [arg; Cconst_int n] when n >= 0 && n <= 0xFFF -> ++ (Iintop_imm(op, n), [arg]) ++ | [Cconst_int n; arg] when n >= 0 && n <= 0xFFF -> ++ (Iintop_imm(op, n), [arg]) ++ | args -> ++ (Iintop op, args) ++ ++(* Instruction selection for conditionals *) ++ ++method! select_condition = function ++ | Cop(Ccmpi cmp, args) -> ++ (Iinttest(Isigned cmp), Ctuple args) ++ | Cop(Ccmpa cmp, args) -> ++ (Iinttest(Iunsigned cmp), Ctuple args) ++ | Cop(Ccmpf cmp, args) -> ++ (Ifloattest(cmp, false), Ctuple args) ++ | Cop(Cand, [arg; Cconst_int 1]) -> ++ (Ioddtest, arg) ++ | arg -> ++ (Itruetest, arg) ++ ++end ++ ++let fundecl f = (new selector)#emit_fundecl f +diff --git a/asmrun/riscv.S b/asmrun/riscv.S +new file mode 100644 +index 000000000..a82048efc +--- /dev/null ++++ b/asmrun/riscv.S +@@ -0,0 +1,424 @@ ++/***********************************************************************/ ++/* */ ++/* OCaml */ ++/* */ ++/* Nicolas Ojeda Bar */ ++/* */ ++/* Copyright 1996 Institut National de Recherche en Informatique et */ ++/* en Automatique. All rights reserved. This file is distributed */ ++/* under the terms of the GNU Library General Public License, with */ ++/* the special exception on linking described in file ../LICENSE. */ ++/* */ ++/***********************************************************************/ ++ ++/* Asm part of the runtime system, RISC-V processor, 64-bit mode */ ++/* Must be preprocessed by cpp */ ++ ++#define TRAP_PTR s1 ++#define ALLOC_PTR s10 ++#define ALLOC_LIMIT s11 ++#define TMP0 t0 ++#define TMP1 t1 ++#define ARG t2 ++ ++#if defined(MODEL_riscv64) ++#define store sd ++#define load ld ++#define WSZ 8 ++#else ++#define store sw ++#define load lw ++#define WSZ 4 ++#endif ++ ++#if defined(__PIC__) ++ .option pic ++#else ++ .option nopic ++#endif ++ ++ .section .text ++/* Invoke the garbage collector. */ ++ ++ .globl caml_system__code_begin ++caml_system__code_begin: ++ ++ .align 2 ++ .globl caml_call_gc ++ .type caml_call_gc, @function ++caml_call_gc: ++ /* Record return address */ ++ store ra, caml_last_return_address, TMP0 ++ /* Record lowest stack address */ ++ mv TMP1, sp ++ store sp, caml_bottom_of_stack, TMP0 ++.Lcaml_call_gc: ++ /* Set up stack space, saving return address */ ++ /* (1 reg for RA, 1 reg for FP, 21 allocatable int regs, 20 caller-save float regs) * 8 */ ++ /* + 1 for alignment */ ++ addi sp, sp, -0x160 ++ mv s0, sp ++ store ra, 0x8(sp) ++ store s0, 0x0(sp) ++ /* Save allocatable integer registers on the stack, ++ in the order given in proc.ml */ ++ store a0, 0x10(sp) ++ store a1, 0x18(sp) ++ store a2, 0x20(sp) ++ store a3, 0x28(sp) ++ store a4, 0x30(sp) ++ store a5, 0x38(sp) ++ store a6, 0x40(sp) ++ store a7, 0x48(sp) ++ store s2, 0x50(sp) ++ store s3, 0x58(sp) ++ store s4, 0x60(sp) ++ store s5, 0x68(sp) ++ store s6, 0x70(sp) ++ store s7, 0x78(sp) ++ store s8, 0x80(sp) ++ store s9, 0x88(sp) ++ store t2, 0x90(sp) ++ store t3, 0x98(sp) ++ store t4, 0xa0(sp) ++ store t5, 0xa8(sp) ++ store t6, 0xb0(sp) ++ /* Save caller-save floating-point registers on the stack ++ (callee-saves are preserved by caml_garbage_collection) */ ++ fsd ft0, 0xb8(sp) ++ fsd ft1, 0xc0(sp) ++ fsd ft2, 0xc8(sp) ++ fsd ft3, 0xd0(sp) ++ fsd ft4, 0xd8(sp) ++ fsd ft5, 0xe0(sp) ++ fsd ft6, 0xe8(sp) ++ fsd ft7, 0xf0(sp) ++ fsd fa0, 0xf8(sp) ++ fsd fa1, 0x100(sp) ++ fsd fa2, 0x108(sp) ++ fsd fa3, 0x110(sp) ++ fsd fa4, 0x118(sp) ++ fsd fa5, 0x120(sp) ++ fsd fa6, 0x128(sp) ++ fsd fa7, 0x130(sp) ++ fsd ft8, 0x138(sp) ++ fsd ft9, 0x140(sp) ++ fsd ft9, 0x148(sp) ++ fsd ft10, 0x150(sp) ++ fsd ft11, 0x158(sp) ++ /* Store pointer to saved integer registers in caml_gc_regs */ ++ addi TMP1, sp, 16 ++ store TMP1, caml_gc_regs, TMP0 ++ /* Save current allocation pointer for debugging purposes */ ++ store ALLOC_PTR, caml_young_ptr, TMP0 ++ /* Save trap pointer in case an exception is raised during GC */ ++ store TRAP_PTR, caml_exception_pointer, TMP0 ++ /* Call the garbage collector */ ++ call caml_garbage_collection ++ /* Restore registers */ ++ load a0, 0x10(sp) ++ load a1, 0x18(sp) ++ load a2, 0x20(sp) ++ load a3, 0x28(sp) ++ load a4, 0x30(sp) ++ load a5, 0x38(sp) ++ load a6, 0x40(sp) ++ load a7, 0x48(sp) ++ load s2, 0x50(sp) ++ load s3, 0x58(sp) ++ load s4, 0x60(sp) ++ load s5, 0x68(sp) ++ load s6, 0x70(sp) ++ load s7, 0x78(sp) ++ load s8, 0x80(sp) ++ load s9, 0x88(sp) ++ load t2, 0x90(sp) ++ load t3, 0x98(sp) ++ load t4, 0xa0(sp) ++ load t5, 0xa8(sp) ++ load t6, 0xb0(sp) ++ fld ft0, 0xb8(sp) ++ fld ft1, 0xc0(sp) ++ fld ft2, 0xc8(sp) ++ fld ft3, 0xd0(sp) ++ fld ft4, 0xd8(sp) ++ fld ft5, 0xe0(sp) ++ fld ft6, 0xe8(sp) ++ fld ft7, 0xf0(sp) ++ fld fa0, 0xf8(sp) ++ fld fa1, 0x100(sp) ++ fld fa2, 0x108(sp) ++ fld fa3, 0x110(sp) ++ fld fa4, 0x118(sp) ++ fld fa5, 0x120(sp) ++ fld fa6, 0x128(sp) ++ fld fa7, 0x130(sp) ++ fld ft8, 0x138(sp) ++ fld ft9, 0x140(sp) ++ fld ft9, 0x148(sp) ++ fld ft10, 0x150(sp) ++ fld ft11, 0x158(sp) ++ /* Reload new allocation pointer and allocation limit */ ++ load ALLOC_PTR, caml_young_ptr ++ load ALLOC_LIMIT, caml_young_limit ++ /* Free stack space and return to caller */ ++ load ra, 0x8(sp) ++ load s0, 0x0(sp) ++ addi sp, sp, 0x160 ++ ret ++ .size caml_call_gc, .-caml_call_gc ++ ++/* Call a C function from OCaml */ ++/* Function to call is in ARG */ ++ ++ .align 2 ++ .globl caml_c_call ++ .type caml_c_call, @function ++caml_c_call: ++ /* Preserve return address in callee-save register s2 */ ++ mv s2, ra ++ /* Record lowest stack address and return address */ ++ store ra, caml_last_return_address, TMP0 ++ store sp, caml_bottom_of_stack, TMP0 ++ /* Make the exception handler alloc ptr available to the C code */ ++ store ALLOC_PTR, caml_young_ptr, TMP0 ++ store TRAP_PTR, caml_exception_pointer, TMP0 ++ /* Call the function */ ++ jalr ARG ++ /* Reload alloc ptr and alloc limit */ ++ load ALLOC_PTR, caml_young_ptr ++ load TRAP_PTR, caml_exception_pointer ++ /* Return */ ++ jr s2 ++ .size caml_c_call, .-caml_c_call ++ ++/* Raise an exception from OCaml */ ++ .align 2 ++ .globl caml_raise_exn ++ .type caml_raise_exn, @function ++caml_raise_exn: ++ /* Test if backtrace is active */ ++ load TMP1, caml_backtrace_active ++ bnez TMP1, 2f ++1: /* Cut stack at current trap handler */ ++ mv sp, TRAP_PTR ++ /* Pop previous handler and jump to it */ ++ load TMP1, 8(sp) ++ load TRAP_PTR, 0(sp) ++ addi sp, sp, 16 ++ jr TMP1 ++2: /* Preserve exception bucket in callee-save register s2 */ ++ mv s2, a0 ++ /* Stash the backtrace */ ++ mv a1, ra ++ mv a2, sp ++ mv a3, TRAP_PTR ++ call caml_stash_backtrace ++ /* Restore exception bucket and raise */ ++ mv a0, s2 ++ j 1b ++ .size caml_raise_exn, .-caml_raise_exn ++ ++ .globl caml_reraise_exn ++ .type caml_reraise_exn, @function ++ ++/* Raise an exception from C */ ++ ++ .align 2 ++ .globl caml_raise_exception ++ .type caml_raise_exception, @function ++caml_raise_exception: ++ load TRAP_PTR, caml_exception_pointer ++ load ALLOC_PTR, caml_young_ptr ++ load ALLOC_LIMIT, caml_young_limit ++ load TMP1, caml_backtrace_active ++ bnez TMP1, 2f ++1: /* Cut stack at current trap handler */ ++ mv sp, TRAP_PTR ++ load TMP1, 8(sp) ++ load TRAP_PTR, 0(sp) ++ addi sp, sp, 16 ++ jr TMP1 ++2: /* Preserve exception bucket in callee-save register s2 */ ++ mv s2, a0 ++ load a1, caml_last_return_address ++ load a2, caml_bottom_of_stack ++ mv a3, TRAP_PTR ++ call caml_stash_backtrace ++ mv a0, s2 ++ j 1b ++ .size caml_raise_exception, .-caml_raise_exception ++ ++/* Start the OCaml program */ ++ ++ .align 2 ++ .globl caml_start_program ++ .type caml_start_program, @function ++caml_start_program: ++ ++ la ARG, caml_program ++ /* Code shared with caml_callback* */ ++ /* Address of OCaml code to call is in ARG */ ++ /* Arguments to the OCaml code are in a0 ... a7 */ ++.Ljump_to_caml: ++ /* Set up stack frame and save callee-save registers */ ++ addi sp, sp, -0xd0 ++ store ra, 0xc0(sp) ++ store s0, 0x0(sp) ++ store s1, 0x8(sp) ++ store s2, 0x10(sp) ++ store s3, 0x18(sp) ++ store s4, 0x20(sp) ++ store s5, 0x28(sp) ++ store s6, 0x30(sp) ++ store s7, 0x38(sp) ++ store s8, 0x40(sp) ++ store s9, 0x48(sp) ++ store s10, 0x50(sp) ++ store s11, 0x58(sp) ++ fsd fs0, 0x60(sp) ++ fsd fs1, 0x68(sp) ++ fsd fs2, 0x70(sp) ++ fsd fs3, 0x78(sp) ++ fsd fs4, 0x80(sp) ++ fsd fs5, 0x88(sp) ++ fsd fs6, 0x90(sp) ++ fsd fs7, 0x98(sp) ++ fsd fs8, 0xa0(sp) ++ fsd fs9, 0xa8(sp) ++ fsd fs10, 0xb0(sp) ++ fsd fs11, 0xb8(sp) ++ addi sp, sp, -32 ++ /* Setup a callback link on the stack */ ++ load TMP1, caml_bottom_of_stack ++ store TMP1, 0(sp) ++ load TMP1, caml_last_return_address ++ store TMP1, 8(sp) ++ load TMP1, caml_gc_regs ++ store TMP1, 16(sp) ++ /* set up a trap frame */ ++ addi sp, sp, -16 ++ load TMP1, caml_exception_pointer ++ store TMP1, 0(sp) ++ lla TMP0, .Ltrap_handler ++ store TMP0, 8(sp) ++ mv TRAP_PTR, sp ++ load ALLOC_PTR, caml_young_ptr ++ load ALLOC_LIMIT, caml_young_limit ++ store x0, caml_last_return_address, TMP0 ++ jalr ARG ++.Lcaml_retaddr: /* pop trap frame, restoring caml_exception_pointer */ ++ load TMP1, 0(sp) ++ store TMP1, caml_exception_pointer, TMP0 ++ addi sp, sp, 16 ++.Lreturn_result: /* pop callback link, restoring global variables */ ++ load TMP1, 0(sp) ++ store TMP1, caml_bottom_of_stack, TMP0 ++ load TMP1, 8(sp) ++ store TMP1, caml_last_return_address, TMP0 ++ load TMP1, 16(sp) ++ store TMP1, caml_gc_regs, TMP0 ++ addi sp, sp, 32 ++ /* Update allocation pointer */ ++ store ALLOC_PTR, caml_young_ptr, TMP0 ++ /* reload callee-save registers and return */ ++ load ra, 0xc0(sp) ++ load s0, 0x0(sp) ++ load s1, 0x8(sp) ++ load s2, 0x10(sp) ++ load s3, 0x18(sp) ++ load s4, 0x20(sp) ++ load s5, 0x28(sp) ++ load s6, 0x30(sp) ++ load s7, 0x38(sp) ++ load s8, 0x40(sp) ++ load s9, 0x48(sp) ++ load s10, 0x50(sp) ++ load s11, 0x58(sp) ++ fld fs0, 0x60(sp) ++ fld fs1, 0x68(sp) ++ fld fs2, 0x70(sp) ++ fld fs3, 0x78(sp) ++ fld fs4, 0x80(sp) ++ fld fs5, 0x88(sp) ++ fld fs6, 0x90(sp) ++ fld fs7, 0x98(sp) ++ fld fs8, 0xa0(sp) ++ fld fs9, 0xa8(sp) ++ fld fs10, 0xb0(sp) ++ fld fs11, 0xb8(sp) ++ addi sp, sp, 0xd0 ++ ret ++.Ltrap_handler: ++ store TRAP_PTR, caml_exception_pointer, TMP0 ++ ori a0, a0, 2 ++ j .Lreturn_result ++ .size caml_start_program, .-caml_start_program ++ ++/* Callback from C to OCaml */ ++ ++ .align 2 ++ .globl caml_callback_exn ++ .type caml_callback_exn, @function ++caml_callback_exn: ++ /* Initial shuffling of arguments (a0 = closure, a1 = first arg) */ ++ mv TMP1, a0 ++ mv a0, a1 /* a0 = first arg */ ++ mv a1, TMP1 /* a1 = closure environment */ ++ load ARG, 0(TMP1) /* code pointer */ ++ j .Ljump_to_caml ++ .size caml_callback_exn, .-caml_callback_exn ++ ++ .align 2 ++ .globl caml_callback2_exn ++ .type caml_callback2_exn, @function ++caml_callback2_exn: ++ /* Initial shuffling of arguments (a0 = closure, a1 = arg1, a2 = arg2) */ ++ mv TMP1, a0 ++ mv a0, a1 ++ mv a1, a2 ++ mv a2, TMP1 ++ la ARG, caml_apply2 ++ j .Ljump_to_caml ++ .size caml_callback2_exn, .-caml_callback2_exn ++ ++ .align 2 ++ .globl caml_callback3_exn ++ .type caml_callback3_exn, @function ++caml_callback3_exn: ++ /* Initial shuffling of argumnets */ ++ /* (a0 = closure, a1 = arg1, a2 = arg2, a3 = arg3) */ ++ mv TMP1, a0 ++ mv a0, a1 ++ mv a1, a2 ++ mv a2, a3 ++ mv a3, TMP1 ++ la ARG, caml_apply3 ++ j .Ljump_to_caml ++ .size caml_callback3_exn, .-caml_callback3_exn ++ ++ .align 2 ++ .globl caml_ml_array_bound_error ++ .type caml_ml_array_bound_error, @function ++caml_ml_array_bound_error: ++ /* Load address of [caml_array_bound_error] in ARG */ ++ la ARG, caml_array_bound_error ++ /* Call that function */ ++ j caml_c_call ++ ++ .globl caml_system__code_end ++caml_system__code_end: ++ ++/* GC roots for callback */ ++ ++ .section .data ++ .align 3 ++ .globl caml_system__frametable ++ .type caml_system__frametable, @object ++caml_system__frametable: ++ .quad 1 /* one descriptor */ ++ .quad .Lcaml_retaddr /* return address into callback */ ++ .short -1 /* negative frame size => use callback link */ ++ .short 0 /* no roots */ ++ .align 3 ++ .size caml_system__frametable, .-caml_system__frametable +diff --git a/byterun/caml/stack.h b/byterun/caml/stack.h +index fd9d528e9..781c2517b 100644 +--- a/byterun/caml/stack.h ++++ b/byterun/caml/stack.h +@@ -75,6 +75,11 @@ + #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) + #endif + ++#ifdef TARGET_riscv /* FIXME FIXME */ ++#define Saved_return_address(sp) *((intnat *)((sp) - 8)) ++#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) ++#endif ++ + /* Structure of OCaml callback contexts */ + + struct caml_context { +diff --git a/configure b/configure +index 786f4cdbe..b88dab26b 100755 +--- a/configure ++++ b/configure +@@ -854,6 +854,7 @@ if test $with_sharedlibs = "yes"; then + arm*-*-freebsd*) natdynlink=true;; + earm*-*-netbsd*) natdynlink=true;; + aarch64-*-linux*) natdynlink=true;; ++ riscv*-*-linux*) natdynlink=true;; + esac + fi + +@@ -947,6 +948,8 @@ case "$target" in + x86_64-*-mingw*) arch=amd64; system=mingw;; + aarch64-*-linux*) arch=arm64; system=linux;; + x86_64-*-cygwin*) arch=amd64; system=cygwin;; ++ riscv32-*-linux*) arch=riscv; model=riscv32; system=linux;; ++ riscv64-*-linux*) arch=riscv; model=riscv64; system=linux;; + esac + + # Some platforms exist both in 32-bit and 64-bit variants, not distinguished +@@ -1023,7 +1026,7 @@ case "$arch,$system" in + aspp="${TOOLPREF}cc -c";; + *,freebsd) as="${TOOLPREF}as" + aspp="${TOOLPREF}cc -c";; +- amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*) ++ amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*|riscv,*) + as="${TOOLPREF}as" + case "$ccfamily" in + clang-*) +-- +2.13.2 + diff --git a/SOURCES/0008-Port-to-the-ARM-64-bits-AArch64-architecture-experim.patch b/SOURCES/0008-Port-to-the-ARM-64-bits-AArch64-architecture-experim.patch deleted file mode 100644 index 37112e0..0000000 --- a/SOURCES/0008-Port-to-the-ARM-64-bits-AArch64-architecture-experim.patch +++ /dev/null @@ -1,2280 +0,0 @@ -From 9f75e98d1cad55d1f6e0131e656acc716177e8d5 Mon Sep 17 00:00:00 2001 -From: Xavier Leroy -Date: Thu, 18 Jul 2013 16:09:20 +0000 -Subject: [PATCH 08/19] Port to the ARM 64-bits (AArch64) architecture - (experimental). Merge of branch branches/arm64. - -git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13909 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 -(cherry picked from commit 055d5c0379e42b4f561cb1fc5159659d8e9a7b6f) ---- - asmcomp/arm64/arch.ml | 146 ++++++++ - asmcomp/arm64/emit.mlp | 742 +++++++++++++++++++++++++++++++++++++++ - asmcomp/arm64/proc.ml | 212 +++++++++++ - asmcomp/arm64/reload.ml | 16 + - asmcomp/arm64/scheduling.ml | 18 + - asmcomp/arm64/selection.ml | 265 ++++++++++++++ - asmcomp/compilenv.ml | 9 + - asmcomp/compilenv.mli | 4 + - asmrun/arm64.S | 535 ++++++++++++++++++++++++++++ - asmrun/signals_osdep.h | 19 + - asmrun/stack.h | 5 + - byterun/interp.c | 6 + - configure | 5 +- - otherlibs/num/bng.c | 6 +- - otherlibs/num/bng_arm64.c | 20 ++ - testsuite/tests/asmcomp/Makefile | 2 +- - testsuite/tests/asmcomp/arm64.S | 52 +++ - testsuite/tests/asmcomp/main.ml | 1 + - 18 files changed, 2057 insertions(+), 6 deletions(-) - create mode 100644 asmcomp/arm64/arch.ml - create mode 100644 asmcomp/arm64/emit.mlp - create mode 100644 asmcomp/arm64/proc.ml - create mode 100644 asmcomp/arm64/reload.ml - create mode 100644 asmcomp/arm64/scheduling.ml - create mode 100644 asmcomp/arm64/selection.ml - create mode 100644 asmrun/arm64.S - create mode 100644 otherlibs/num/bng_arm64.c - create mode 100644 testsuite/tests/asmcomp/arm64.S - -diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml -new file mode 100644 -index 0000000..a53251f ---- /dev/null -+++ b/asmcomp/arm64/arch.ml -@@ -0,0 +1,146 @@ -+(***********************************************************************) -+(* *) -+(* OCaml *) -+(* *) -+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -+(* Benedikt Meurer, University of Siegen *) -+(* *) -+(* Copyright 2013 Institut National de Recherche en Informatique *) -+(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) -+(* reserved. This file is distributed under the terms of the Q *) -+(* Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+let command_line_options = [] -+ -+(* Specific operations for the ARM processor, 64-bit mode *) -+ -+open Format -+ -+let command_line_options = [] -+ -+(* Addressing modes *) -+ -+type addressing_mode = -+ | Iindexed of int (* reg + displ *) -+ | Ibased of string * int (* global var + displ *) -+ -+(* We do not support the reg + shifted reg addressing mode, because -+ what we really need is reg + shifted reg + displ, -+ and this is decomposed in two instructions (reg + shifted reg -> tmp, -+ then addressing tmp + displ). *) -+ -+(* Specific operations *) -+ -+type specific_operation = -+ | Ishiftarith of arith_operation * int -+ | Ishiftcheckbound of int -+ | Imuladd (* multiply and add *) -+ | Imulsub (* multiply and subtract *) -+ | Inegmulf (* floating-point negate and multiply *) -+ | Imuladdf (* floating-point multiply and add *) -+ | Inegmuladdf (* floating-point negate, multiply and add *) -+ | Imulsubf (* floating-point multiply and subtract *) -+ | Inegmulsubf (* floating-point negate, multiply and subtract *) -+ | Isqrtf (* floating-point square root *) -+ | Ibswap of int (* endianess conversion *) -+ -+and arith_operation = -+ Ishiftadd -+ | Ishiftsub -+ -+(* Sizes, endianness *) -+ -+let big_endian = false -+ -+let size_addr = 8 -+let size_int = 8 -+let size_float = 8 -+ -+let allow_unaligned_access = false -+ -+(* Behavior of division *) -+ -+let division_crashes_on_overflow = false -+ -+(* Operations on addressing modes *) -+ -+let identity_addressing = Iindexed 0 -+ -+let offset_addressing addr delta = -+ match addr with -+ | Iindexed n -> Iindexed(n + delta) -+ | Ibased(s, n) -> Ibased(s, n + delta) -+ -+let num_args_addressing = function -+ | Iindexed n -> 1 -+ | Ibased(s, n) -> 0 -+ -+(* Printing operations and addressing modes *) -+ -+let print_addressing printreg addr ppf arg = -+ match addr with -+ | Iindexed n -> -+ printreg ppf arg.(0); -+ if n <> 0 then fprintf ppf " + %i" n -+ | Ibased(s, 0) -> -+ fprintf ppf "\"%s\"" s -+ | Ibased(s, n) -> -+ fprintf ppf "\"%s\" + %i" s n -+ -+let print_specific_operation printreg op ppf arg = -+ match op with -+ | Ishiftarith(op, shift) -> -+ let op_name = function -+ | Ishiftadd -> "+" -+ | Ishiftsub -> "-" in -+ let shift_mark = -+ if shift >= 0 -+ then sprintf "<< %i" shift -+ else sprintf ">> %i" (-shift) in -+ fprintf ppf "%a %s %a %s" -+ printreg arg.(0) (op_name op) printreg arg.(1) shift_mark -+ | Ishiftcheckbound n -> -+ fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) -+ | Imuladd -> -+ fprintf ppf "(%a * %a) + %a" -+ printreg arg.(0) -+ printreg arg.(1) -+ printreg arg.(2) -+ | Imulsub -> -+ fprintf ppf "-(%a * %a) + %a" -+ printreg arg.(0) -+ printreg arg.(1) -+ printreg arg.(2) -+ | Inegmulf -> -+ fprintf ppf "-f (%a *f %a)" -+ printreg arg.(0) -+ printreg arg.(1) -+ | Imuladdf -> -+ fprintf ppf "%a +f (%a *f %a)" -+ printreg arg.(0) -+ printreg arg.(1) -+ printreg arg.(2) -+ | Inegmuladdf -> -+ fprintf ppf "(-f %a) -f (%a *f %a)" -+ printreg arg.(0) -+ printreg arg.(1) -+ printreg arg.(2) -+ | Imulsubf -> -+ fprintf ppf "%a -f (%a *f %a)" -+ printreg arg.(0) -+ printreg arg.(1) -+ printreg arg.(2) -+ | Inegmulsubf -> -+ fprintf ppf "(-f %a) +f (%a *f %a)" -+ printreg arg.(0) -+ printreg arg.(1) -+ printreg arg.(2) -+ | Isqrtf -> -+ fprintf ppf "sqrtf %a" -+ printreg arg.(0) -+ | Ibswap n -> -+ fprintf ppf "bswap%i %a" n -+ printreg arg.(0) -+ -diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp -new file mode 100644 -index 0000000..fc9649c ---- /dev/null -+++ b/asmcomp/arm64/emit.mlp -@@ -0,0 +1,742 @@ -+(***********************************************************************) -+(* *) -+(* OCaml *) -+(* *) -+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -+(* Benedikt Meurer, University of Siegen *) -+(* *) -+(* Copyright 2013 Institut National de Recherche en Informatique *) -+(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) -+(* reserved. This file is distributed under the terms of the Q *) -+(* Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Emission of ARM assembly code, 64-bit mode *) -+ -+open Misc -+open Cmm -+open Arch -+open Proc -+open Reg -+open Mach -+open Linearize -+open Emitaux -+ -+(* Tradeoff between code size and code speed *) -+ -+let fastcode_flag = ref true -+ -+(* Names for special regs *) -+ -+let reg_trap_ptr = phys_reg 23 -+let reg_alloc_ptr = phys_reg 24 -+let reg_alloc_limit = phys_reg 25 -+let reg_tmp1 = phys_reg 26 -+let reg_tmp2 = phys_reg 27 -+let reg_x15 = phys_reg 15 -+ -+(* Output a label *) -+ -+let emit_label lbl = -+ emit_string ".L"; emit_int lbl -+ -+let emit_data_label lbl = -+ emit_string ".Ld"; emit_int lbl -+ -+(* Symbols *) -+ -+let emit_symbol s = -+ Emitaux.emit_symbol '$' s -+ -+(* Output a pseudo-register *) -+ -+let emit_reg = function -+ {loc = Reg r} -> emit_string (register_name r) -+ | _ -> fatal_error "Emit.emit_reg" -+ -+(* Likewise, but with the 32-bit name of the register *) -+ -+let int_reg_name_w = -+ [| "w0"; "w1"; "w2"; "w3"; "w4"; "w5"; "w6"; "w7"; -+ "w8"; "w9"; "w10"; "w11"; "w12"; "w13"; "w14"; "w15"; -+ "w19"; "w20"; "w21"; "w22"; "w23"; "w24"; "w25"; -+ "w26"; "w27"; "w28"; "w16"; "w17" |] -+ -+let emit_wreg = function -+ {loc = Reg r} -> emit_string int_reg_name_w.(r) -+ | _ -> fatal_error "Emit.emit_wreg" -+ -+(* Layout of the stack frame *) -+ -+let stack_offset = ref 0 -+ -+let frame_size () = -+ let sz = -+ !stack_offset + -+ 8 * num_stack_slots.(0) + -+ 8 * num_stack_slots.(1) + -+ (if !contains_calls then 8 else 0) -+ in Misc.align sz 16 -+ -+let slot_offset loc cl = -+ match loc with -+ Incoming n -> -+ assert (n >= 0); -+ frame_size() + n -+ | Local n -> -+ !stack_offset + -+ (if cl = 0 -+ then n * 8 -+ else num_stack_slots.(0) * 8 + n * 8) -+ | Outgoing n -> -+ assert (n >= 0); -+ n -+ -+(* Output a stack reference *) -+ -+let emit_stack r = -+ match r.loc with -+ | Stack s -> -+ let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]` -+ | _ -> fatal_error "Emit.emit_stack" -+ -+(* Output an addressing mode *) -+ -+let emit_symbol_offset s ofs = -+ emit_symbol s; -+ if ofs > 0 then `+{emit_int ofs}` -+ else if ofs < 0 then `-{emit_int (-ofs)}` -+ else () -+ -+let emit_addressing addr r = -+ match addr with -+ | Iindexed ofs -> -+ `[{emit_reg r}, #{emit_int ofs}]` -+ | Ibased(s, ofs) -> -+ `[{emit_reg r}, #:lo12:{emit_symbol_offset s ofs}]` -+ -+(* Record live pointers at call points *) -+ -+let record_frame_label live dbg = -+ let lbl = new_label() in -+ let live_offset = ref [] in -+ Reg.Set.iter -+ (function -+ {typ = Addr; loc = Reg r} -> -+ live_offset := ((r lsl 1) + 1) :: !live_offset -+ | {typ = Addr; loc = Stack s} as reg -> -+ live_offset := slot_offset s (register_class reg) :: !live_offset -+ | _ -> ()) -+ live; -+ frame_descriptors := -+ { fd_lbl = lbl; -+ fd_frame_size = frame_size(); -+ fd_live_offset = !live_offset; -+ fd_debuginfo = dbg } :: !frame_descriptors; -+ lbl -+ -+let record_frame live dbg = -+ let lbl = record_frame_label live dbg in `{emit_label lbl}:` -+ -+(* Record calls to the GC -- we've moved them out of the way *) -+ -+type gc_call = -+ { gc_lbl: label; (* Entry label *) -+ gc_return_lbl: label; (* Where to branch after GC *) -+ gc_frame_lbl: label } (* Label of frame descriptor *) -+ -+let call_gc_sites = ref ([] : gc_call list) -+ -+let emit_call_gc gc = -+ `{emit_label gc.gc_lbl}: bl {emit_symbol "caml_call_gc"}\n`; -+ `{emit_label gc.gc_frame_lbl}: b {emit_label gc.gc_return_lbl}\n` -+ -+(* Record calls to caml_ml_array_bound_error. -+ In debug mode, we maintain one call to caml_ml_array_bound_error -+ per bound check site. Otherwise, we can share a single call. *) -+ -+type bound_error_call = -+ { bd_lbl: label; (* Entry label *) -+ bd_frame_lbl: label } (* Label of frame descriptor *) -+ -+let bound_error_sites = ref ([] : bound_error_call list) -+ -+let bound_error_label dbg = -+ if !Clflags.debug || !bound_error_sites = [] then begin -+ let lbl_bound_error = new_label() in -+ let lbl_frame = record_frame_label Reg.Set.empty dbg in -+ bound_error_sites := -+ { bd_lbl = lbl_bound_error; -+ bd_frame_lbl = lbl_frame } :: !bound_error_sites; -+ lbl_bound_error -+ end else begin -+ let bd = List.hd !bound_error_sites in bd.bd_lbl -+ end -+ -+let emit_call_bound_error bd = -+ `{emit_label bd.bd_lbl}: bl {emit_symbol "caml_ml_array_bound_error"}\n`; -+ `{emit_label bd.bd_frame_lbl}:\n` -+ -+(* Names of various instructions *) -+ -+let name_for_comparison = function -+ | Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le" -+ | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt" -+ | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls" -+ | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" -+ -+let name_for_int_operation = function -+ | Iadd -> "add" -+ | Isub -> "sub" -+ | Imul -> "mul" -+ | Idiv -> "sdiv" -+ | Iand -> "and" -+ | Ior -> "orr" -+ | Ixor -> "eor" -+ | Ilsl -> "lsl" -+ | Ilsr -> "lsr" -+ | Iasr -> "asr" -+ | _ -> assert false -+ -+(* Load an integer constant into a register *) -+ -+let emit_intconst dst n = -+ let rec emit_pos first shift = -+ if shift < 0 then begin -+ if first then ` mov {emit_reg dst}, xzr\n` -+ end else begin -+ let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in -+ if s = 0n then emit_pos first (shift - 16) else begin -+ if first then -+ ` movz {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n` -+ else -+ ` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`; -+ emit_pos false (shift - 16) -+ end -+ end -+ and emit_neg first shift = -+ if shift < 0 then begin -+ if first then ` movn {emit_reg dst}, #0\n` -+ end else begin -+ let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in -+ if s = 0xFFFFn then emit_neg first (shift - 16) else begin -+ if first then -+ ` movn {emit_reg dst}, #{emit_nativeint (Nativeint.logxor s 0xFFFFn)}, lsl #{emit_int shift}\n` -+ else -+ ` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`; -+ emit_neg false (shift - 16) -+ end -+ end -+ in -+ if n < 0n then emit_neg true 48 else emit_pos true 48 -+ -+(* Recognize float constants appropriate for FMOV dst, #fpimm instruction: -+ "a normalized binary floating point encoding with 1 sign bit, 4 -+ bits of fraction and a 3-bit exponent" *) -+ -+let is_immediate_float bits = -+ let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in -+ let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in -+ exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant -+ -+(* Adjust sp (up or down) by the given byte amount *) -+ -+let emit_stack_adjustment n = -+ let instr = if n < 0 then "sub" else "add" in -+ let m = abs n in -+ assert (m < 0x1_000_000); -+ let ml = m land 0xFFF and mh = m land 0xFFF_000 in -+ if mh <> 0 then ` {emit_string instr} sp, sp, #{emit_int mh}\n`; -+ if ml <> 0 then ` {emit_string instr} sp, sp, #{emit_int ml}\n`; -+ if n <> 0 then cfi_adjust_cfa_offset (-n) -+ -+(* Deallocate the stack frame and reload the return address -+ before a return or tail call *) -+ -+let output_epilogue f = -+ let n = frame_size() in -+ if !contains_calls then -+ ` ldr x30, [sp, #{emit_int (n-8)}]\n`; -+ if n > 0 then -+ emit_stack_adjustment n; -+ f(); -+ (* reset CFA back because function body may continue *) -+ if n > 0 then cfi_adjust_cfa_offset n -+ -+(* Name of current function *) -+let function_name = ref "" -+(* Entry point for tail recursive calls *) -+let tailrec_entry_point = ref 0 -+(* Pending floating-point literals *) -+let float_literals = ref ([] : (int64 * label) list) -+ -+(* Label a floating-point literal *) -+let float_literal f = -+ try -+ List.assoc f !float_literals -+ with Not_found -> -+ let lbl = new_label() in -+ float_literals := (f, lbl) :: !float_literals; -+ lbl -+ -+(* Emit all pending literals *) -+let emit_literals() = -+ if !float_literals <> [] then begin -+ ` .align 3\n`; -+ List.iter -+ (fun (f, lbl) -> -+ `{emit_label lbl}: .quad `; emit_printf "0x%Lx\n" f) -+ !float_literals; -+ float_literals := [] -+ end -+ -+(* Emit code to load the address of a symbol *) -+ -+let emit_load_symbol_addr dst s = -+ if (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit s then begin -+ ` adrp {emit_reg dst}, {emit_symbol s}\n`; -+ ` add {emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n` -+ end else begin -+ ` adrp {emit_reg dst}, :got:{emit_symbol s}\n`; -+ ` ldr {emit_reg dst}, [{emit_reg dst}, #:got_lo12:{emit_symbol s}]\n` -+ end -+ -+(* Output the assembly code for an instruction *) -+ -+let emit_instr i = -+ emit_debug_info i.dbg; -+ match i.desc with -+ | Lend -> () -+ | Lop(Imove | Ispill | Ireload) -> -+ let src = i.arg.(0) and dst = i.res.(0) in -+ if src.loc <> dst.loc then begin -+ match (src, dst) with -+ | {loc = Reg _; typ = Float}, {loc = Reg _} -> -+ ` fmov {emit_reg dst}, {emit_reg src}\n` -+ | {loc = Reg _}, {loc = Reg _} -> -+ ` mov {emit_reg dst}, {emit_reg src}\n` -+ | {loc = Reg _}, {loc = Stack _} -> -+ ` str {emit_reg src}, {emit_stack dst}\n` -+ | {loc = Stack _}, {loc = Reg _} -> -+ ` ldr {emit_reg dst}, {emit_stack src}\n` -+ | _ -> -+ assert false -+ end -+ | Lop(Iconst_int n) -> -+ emit_intconst i.res.(0) n -+ | Lop(Iconst_float f) -> -+ let b = Int64.bits_of_float(float_of_string f) in -+ if b = 0L then -+ ` fmov {emit_reg i.res.(0)}, xzr /* {emit_string f} */\n` -+ else if is_immediate_float b then -+ ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b} /* {emit_string f} */\n` -+ else begin -+ let lbl = float_literal b in -+ ` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`; -+ ` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}] /* {emit_string f} */\n` -+ end -+ | Lop(Iconst_symbol s) -> -+ emit_load_symbol_addr i.res.(0) s -+ | Lop(Icall_ind) -> -+ ` blr {emit_reg i.arg.(0)}\n`; -+ `{record_frame i.live i.dbg}\n` -+ | Lop(Icall_imm s) -> -+ ` bl {emit_symbol s}\n`; -+ `{record_frame i.live i.dbg}\n` -+ | Lop(Itailcall_ind) -> -+ output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`) -+ | Lop(Itailcall_imm s) -> -+ if s = !function_name then -+ ` b {emit_label !tailrec_entry_point}\n` -+ else -+ output_epilogue (fun () -> ` b {emit_symbol s}\n`) -+ | Lop(Iextcall(s, false)) -> -+ ` bl {emit_symbol s}\n` -+ | Lop(Iextcall(s, true)) -> -+ emit_load_symbol_addr reg_x15 s; -+ ` bl {emit_symbol "caml_c_call"}\n`; -+ `{record_frame i.live i.dbg}\n` -+ | Lop(Istackoffset n) -> -+ assert (n mod 16 = 0); -+ emit_stack_adjustment (-n); -+ stack_offset := !stack_offset + n -+ | Lop(Iload(size, addr)) -> -+ let dst = i.res.(0) in -+ let base = -+ match addr with -+ | Iindexed ofs -> i.arg.(0) -+ | Ibased(s, ofs) -> -+ ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; -+ reg_tmp1 in -+ begin match size with -+ | Byte_unsigned -> -+ ` ldrb {emit_wreg dst}, {emit_addressing addr base}\n` -+ | Byte_signed -> -+ ` ldrsb {emit_reg dst}, {emit_addressing addr base}\n` -+ | Sixteen_unsigned -> -+ ` ldrh {emit_wreg dst}, {emit_addressing addr base}\n` -+ | Sixteen_signed -> -+ ` ldrsh {emit_reg dst}, {emit_addressing addr base}\n` -+ | Thirtytwo_unsigned -> -+ ` ldr {emit_wreg dst}, {emit_addressing addr base}\n` -+ | Thirtytwo_signed -> -+ ` ldrsw {emit_reg dst}, {emit_addressing addr base}\n` -+ | Single -> -+ ` ldr s7, {emit_addressing addr base}\n`; -+ ` fcvt {emit_reg dst}, s7\n` -+ | Word | Double | Double_u -> -+ ` ldr {emit_reg dst}, {emit_addressing addr base}\n` -+ end -+ | Lop(Istore(size, addr)) -> -+ let src = i.arg.(0) in -+ let base = -+ match addr with -+ | Iindexed ofs -> i.arg.(1) -+ | Ibased(s, ofs) -> -+ ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; -+ reg_tmp1 in -+ begin match size with -+ | Byte_unsigned | Byte_signed -> -+ ` strb {emit_wreg src}, {emit_addressing addr base}\n` -+ | Sixteen_unsigned | Sixteen_signed -> -+ ` strh {emit_wreg src}, {emit_addressing addr base}\n` -+ | Thirtytwo_unsigned | Thirtytwo_signed -> -+ ` str {emit_wreg src}, {emit_addressing addr base}\n` -+ | Single -> -+ ` fcvt s7, {emit_reg src}\n`; -+ ` str s7, {emit_addressing addr base}\n`; -+ | Word | Double | Double_u -> -+ ` str {emit_reg src}, {emit_addressing addr base}\n` -+ end -+ | Lop(Ialloc n) -> -+ let lbl_frame = record_frame_label i.live i.dbg in -+ if !fastcode_flag then begin -+ let lbl_redo = new_label() in -+ let lbl_call_gc = new_label() in -+ `{emit_label lbl_redo}:`; -+ ` sub {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int n}\n`; -+ ` cmp {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_limit}\n`; -+ ` add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`; -+ ` b.lo {emit_label lbl_call_gc}\n`; -+ call_gc_sites := -+ { gc_lbl = lbl_call_gc; -+ gc_return_lbl = lbl_redo; -+ gc_frame_lbl = lbl_frame } :: !call_gc_sites -+ end else begin -+ begin match n with -+ | 16 -> ` bl {emit_symbol "caml_alloc1"}\n` -+ | 24 -> ` bl {emit_symbol "caml_alloc2"}\n` -+ | 32 -> ` bl {emit_symbol "caml_alloc3"}\n` -+ | _ -> emit_intconst reg_x15 (Nativeint.of_int n); -+ ` bl {emit_symbol "caml_allocN"}\n` -+ end; -+ `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n` -+ end -+ | Lop(Iintop(Icomp cmp)) -> -+ ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` -+ | Lop(Iintop_imm(Icomp cmp, n)) -> -+ ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; -+ ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` -+ | Lop(Iintop Icheckbound) -> -+ let lbl = bound_error_label i.dbg in -+ ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ ` b.ls {emit_label lbl}\n` -+ | Lop(Iintop_imm(Icheckbound, n)) -> -+ let lbl = bound_error_label i.dbg in -+ ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; -+ ` b.ls {emit_label lbl}\n` -+ | Lop(Ispecific(Ishiftcheckbound shift)) -> -+ let lbl = bound_error_label i.dbg in -+ ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; -+ ` b.cs {emit_label lbl}\n` -+ | Lop(Iintop Imod) -> -+ ` sdiv {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ ` msub {emit_reg i.res.(0)}, {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` -+ | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *) -+ let l = Misc.log2 n in -+ ` asr {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, #63\n`; -+ ` add {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg reg_tmp1}, lsr {emit_int (64-l)}\n`; -+ ` asr {emit_reg i.res.(0)}, {emit_reg reg_tmp1}, {emit_int l}\n` -+ | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) -+ let l = Misc.log2 n in -+ ` asr {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, #63\n`; -+ ` add {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg reg_tmp1}, lsr {emit_int (64-l)}\n`; -+ ` asr {emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_int l}\n`; -+ ` sub {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg reg_tmp1}, lsl {emit_int l}\n` -+ | Lop(Iintop op) -> -+ let instr = name_for_int_operation op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` -+ | Lop(Iintop_imm(op, n)) -> -+ let instr = name_for_int_operation op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n` -+ | Lop(Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf as op) -> -+ let instr = (match op with -+ | Ifloatofint -> "scvtf" -+ | Iintoffloat -> "fcvtzs" -+ | Iabsf -> "fabs" -+ | Inegf -> "fneg" -+ | Ispecific Isqrtf -> "fsqrt" -+ | _ -> assert false) in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` -+ | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) -> -+ let instr = (match op with -+ | Iaddf -> "fadd" -+ | Isubf -> "fsub" -+ | Imulf -> "fmul" -+ | Idivf -> "fdiv" -+ | Ispecific Inegmulf -> "fnmul" -+ | _ -> assert false) in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` -+ | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) -> -+ let instr = (match op with -+ | Imuladdf -> "fmadd" -+ | Inegmuladdf -> "fnmadd" -+ | Imulsubf -> "fmsub" -+ | Inegmulsubf -> "fnmsub" -+ | _ -> assert false) in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, {emit_reg i.arg.(0)}\n` -+ | Lop(Ispecific(Ishiftarith(op, shift))) -> -+ let instr = (match op with -+ Ishiftadd -> "add" -+ | Ishiftsub -> "sub") in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; -+ if shift >= 0 -+ then `, lsl #{emit_int shift}\n` -+ else `, asr #{emit_int (-shift)}\n` -+ | Lop(Ispecific(Imuladd | Imulsub as op)) -> -+ let instr = (match op with -+ Imuladd -> "madd" -+ | Imulsub -> "msub" -+ | _ -> assert false) in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` -+ | Lop(Ispecific(Ibswap size)) -> -+ begin match size with -+ | 16 -> -+ ` rev16 {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`; -+ ` ubfm {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #0, #16\n` -+ | 32 -> -+ ` rev {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n` -+ | 64 -> -+ ` rev {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` -+ | _ -> -+ assert false -+ end -+ | Lreloadretaddr -> -+ () -+ | Lreturn -> -+ output_epilogue (fun () -> ` ret\n`) -+ | Llabel lbl -> -+ `{emit_label lbl}:\n` -+ | Lbranch lbl -> -+ ` b {emit_label lbl}\n` -+ | Lcondbranch(tst, lbl) -> -+ begin match tst with -+ | Itruetest -> -+ ` cbnz {emit_reg i.arg.(0)}, {emit_label lbl}\n` -+ | Ifalsetest -> -+ ` cbz {emit_reg i.arg.(0)}, {emit_label lbl}\n` -+ | Iinttest cmp -> -+ ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ let comp = name_for_comparison cmp in -+ ` b.{emit_string comp} {emit_label lbl}\n` -+ | Iinttest_imm(cmp, n) -> -+ ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; -+ let comp = name_for_comparison cmp in -+ ` b.{emit_string comp} {emit_label lbl}\n` -+ | Ifloattest(cmp, neg) -> -+ let comp = (match (cmp, neg) with -+ | (Ceq, false) | (Cne, true) -> "eq" -+ | (Cne, false) | (Ceq, true) -> "ne" -+ | (Clt, false) -> "cc" -+ | (Clt, true) -> "cs" -+ | (Cle, false) -> "ls" -+ | (Cle, true) -> "hi" -+ | (Cgt, false) -> "gt" -+ | (Cgt, true) -> "le" -+ | (Cge, false) -> "ge" -+ | (Cge, true) -> "lt") in -+ ` fcmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ ` b.{emit_string comp} {emit_label lbl}\n` -+ | Ioddtest -> -+ ` tbnz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n` -+ | Ieventest -> -+ ` tbz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n` -+ end -+ | Lcondbranch3(lbl0, lbl1, lbl2) -> -+ ` cmp {emit_reg i.arg.(0)}, #1\n`; -+ begin match lbl0 with -+ None -> () -+ | Some lbl -> ` b.lt {emit_label lbl}\n` -+ end; -+ begin match lbl1 with -+ None -> () -+ | Some lbl -> ` b.eq {emit_label lbl}\n` -+ end; -+ begin match lbl2 with -+ None -> () -+ | Some lbl -> ` b.gt {emit_label lbl}\n` -+ end -+ | Lswitch jumptbl -> -+ let lbltbl = new_label() in -+ ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; -+ ` add {emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2\n`; -+ ` br {emit_reg reg_tmp1}\n`; -+ `{emit_label lbltbl}:`; -+ for j = 0 to Array.length jumptbl - 1 do -+ ` b {emit_label jumptbl.(j)}\n` -+ done -+(* Alternative: -+ let lbltbl = new_label() in -+ ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; -+ ` ldr {emit_wreg reg_tmp2}, [{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2]\n`; -+ ` add {emit_reg reg_tmp1}, {emit_wreg reg_tmp2}, sxtb\n`; -+ ` br {emit_reg reg_tmp1}\n`; -+ `{emit_label lbltbl}:\n`; -+ for j = 0 to Array.length jumptbl - 1 do -+ ` .word {emit_label jumptbl.(j)} - {emit_label lbltbl}\n` -+ done -+*) -+ | Lsetuptrap lbl -> -+ let lblnext = new_label() in -+ ` adr {emit_reg reg_tmp1}, {emit_label lblnext}\n`; -+ ` b {emit_label lbl}\n`; -+ `{emit_label lblnext}:\n` -+ | Lpushtrap -> -+ stack_offset := !stack_offset + 16; -+ ` str {emit_reg reg_trap_ptr}, [sp, -16]!\n`; -+ ` str {emit_reg reg_tmp1}, [sp, #8]\n`; -+ cfi_adjust_cfa_offset 16; -+ ` mov {emit_reg reg_trap_ptr}, sp\n` -+ | Lpoptrap -> -+ ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; -+ cfi_adjust_cfa_offset (-16); -+ stack_offset := !stack_offset - 16 -+ | Lraise -> -+ if !Clflags.debug then begin -+ ` bl {emit_symbol "caml_raise_exn"}\n`; -+ `{record_frame Reg.Set.empty i.dbg}\n` -+ end else begin -+ ` mov sp, {emit_reg reg_trap_ptr}\n`; -+ ` ldr {emit_reg reg_tmp1}, [sp, #8]\n`; -+ ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; -+ ` br {emit_reg reg_tmp1}\n` -+ end -+ -+(* Emission of an instruction sequence *) -+ -+let rec emit_all i = -+ if i.desc = Lend then () else (emit_instr i; emit_all i.next) -+ -+(* Emission of the profiling prelude *) -+ -+let emit_profile() = () (* TODO *) -+(* -+ match Config.system with -+ "linux_eabi" | "linux_eabihf" -> -+ ` push \{lr}\n`; -+ ` {emit_call "__gnu_mcount_nc"}\n` -+ | _ -> () -+*) -+ -+(* Emission of a function declaration *) -+ -+let fundecl fundecl = -+ function_name := fundecl.fun_name; -+ fastcode_flag := fundecl.fun_fast; -+ tailrec_entry_point := new_label(); -+ float_literals := []; -+ stack_offset := 0; -+ call_gc_sites := []; -+ bound_error_sites := []; -+ ` .text\n`; -+ ` .align 2\n`; -+ ` .globl {emit_symbol fundecl.fun_name}\n`; -+ ` .type {emit_symbol fundecl.fun_name}, %function\n`; -+ `{emit_symbol fundecl.fun_name}:\n`; -+ emit_debug_info fundecl.fun_dbg; -+ cfi_startproc(); -+ if !Clflags.gprofile then emit_profile(); -+ let n = frame_size() in -+ if n > 0 then -+ emit_stack_adjustment (-n); -+ if !contains_calls then -+ ` str x30, [sp, #{emit_int (n-8)}]\n`; -+ `{emit_label !tailrec_entry_point}:\n`; -+ emit_all fundecl.fun_body; -+ List.iter emit_call_gc !call_gc_sites; -+ List.iter emit_call_bound_error !bound_error_sites; -+ cfi_endproc(); -+ ` .type {emit_symbol fundecl.fun_name}, %function\n`; -+ ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`; -+ emit_literals() -+ -+(* Emission of data *) -+ -+let emit_item = function -+ | Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; -+ | Cdefine_symbol s -> `{emit_symbol s}:\n` -+ | Cdefine_label lbl -> `{emit_data_label lbl}:\n` -+ | Cint8 n -> ` .byte {emit_int n}\n` -+ | Cint16 n -> ` .short {emit_int n}\n` -+ | Cint32 n -> ` .long {emit_nativeint n}\n` -+ | Cint n -> ` .quad {emit_nativeint n}\n` -+ | Csingle f -> emit_float32_directive ".long" f -+ | Cdouble f -> emit_float64_directive ".quad" f -+ | Csymbol_address s -> ` .quad {emit_symbol s}\n` -+ | Clabel_address lbl -> ` .quad {emit_data_label lbl}\n` -+ | Cstring s -> emit_string_directive " .ascii " s -+ | Cskip n -> if n > 0 then ` .space {emit_int n}\n` -+ | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` -+ -+let data l = -+ ` .data\n`; -+ List.iter emit_item l -+ -+(* Beginning / end of an assembly file *) -+ -+let begin_assembly() = -+ reset_debug_info(); -+ let lbl_begin = Compilenv.make_symbol (Some "data_begin") in -+ ` .data\n`; -+ ` .globl {emit_symbol lbl_begin}\n`; -+ `{emit_symbol lbl_begin}:\n`; -+ let lbl_begin = Compilenv.make_symbol (Some "code_begin") in -+ ` .text\n`; -+ ` .globl {emit_symbol lbl_begin}\n`; -+ `{emit_symbol lbl_begin}:\n` -+ -+let end_assembly () = -+ let lbl_end = Compilenv.make_symbol (Some "code_end") in -+ ` .text\n`; -+ ` .globl {emit_symbol lbl_end}\n`; -+ `{emit_symbol lbl_end}:\n`; -+ let lbl_end = Compilenv.make_symbol (Some "data_end") in -+ ` .data\n`; -+ ` .globl {emit_symbol lbl_end}\n`; -+ `{emit_symbol lbl_end}:\n`; -+ ` .long 0\n`; -+ let lbl = Compilenv.make_symbol (Some "frametable") in -+ ` .globl {emit_symbol lbl}\n`; -+ `{emit_symbol lbl}:\n`; -+ emit_frames -+ { efa_label = (fun lbl -> -+ ` .type {emit_label lbl}, %function\n`; -+ ` .quad {emit_label lbl}\n`); -+ efa_16 = (fun n -> ` .short {emit_int n}\n`); -+ efa_32 = (fun n -> ` .long {emit_int32 n}\n`); -+ efa_word = (fun n -> ` .quad {emit_int n}\n`); -+ efa_align = (fun n -> ` .align {emit_int(Misc.log2 n)}\n`); -+ efa_label_rel = (fun lbl ofs -> -+ ` .long {emit_label lbl} - . + {emit_int32 ofs}\n`); -+ efa_def_label = (fun lbl -> `{emit_label lbl}:\n`); -+ efa_string = (fun s -> emit_string_directive " .asciz " s) }; -+ ` .type {emit_symbol lbl}, %object\n`; -+ ` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`; -+ begin match Config.system with -+ | "linux" -> -+ (* Mark stack as non-executable *) -+ ` .section .note.GNU-stack,\"\",%progbits\n` -+ | _ -> () -+ end -diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml -new file mode 100644 -index 0000000..b52c2fd ---- /dev/null -+++ b/asmcomp/arm64/proc.ml -@@ -0,0 +1,212 @@ -+(***********************************************************************) -+(* *) -+(* OCaml *) -+(* *) -+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -+(* Benedikt Meurer, University of Siegen *) -+(* *) -+(* Copyright 2013 Institut National de Recherche en Informatique *) -+(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) -+(* reserved. This file is distributed under the terms of the Q *) -+(* Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Description of the ARM processor in 64-bit mode *) -+ -+open Misc -+open Cmm -+open Reg -+open Arch -+open Mach -+ -+(* Instruction selection *) -+ -+let word_addressed = false -+ -+(* Registers available for register allocation *) -+ -+(* Integer register map: -+ x0 - x15 general purpose (caller-save) -+ x16, x17 temporaries (used by call veeners) -+ x18 platform register (reserved) -+ x19 - x25 general purpose (callee-save) -+ x26 trap pointer -+ x27 alloc pointer -+ x28 alloc limit -+ x29 frame pointer -+ x30 return address -+ sp / xzr stack pointer / zero register -+ Floating-point register map: -+ d0 - d7 general purpose (caller-save) -+ d8 - d15 general purpose (callee-save) -+ d16 - d31 generat purpose (caller-save) -+*) -+ -+let int_reg_name = -+ [| "x0"; "x1"; "x2"; "x3"; "x4"; "x5"; "x6"; "x7"; -+ "x8"; "x9"; "x10"; "x11"; "x12"; "x13"; "x14"; "x15"; -+ "x19"; "x20"; "x21"; "x22"; "x23"; "x24"; "x25"; -+ "x26"; "x27"; "x28"; "x16"; "x17" |] -+ -+let float_reg_name = -+ [| "d0"; "d1"; "d2"; "d3"; "d4"; "d5"; "d6"; "d7"; -+ "d8"; "d9"; "d10"; "d11"; "d12"; "d13"; "d14"; "d15"; -+ "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23"; -+ "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |] -+ -+let num_register_classes = 2 -+ -+let register_class r = -+ match r.typ with -+ | (Int | Addr) -> 0 -+ | Float -> 1 -+ -+let num_available_registers = -+ [| 23; 32 |] (* first 23 int regs allocatable; all float regs allocatable *) -+ -+let first_available_register = -+ [| 0; 100 |] -+ -+let register_name r = -+ if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) -+ -+let rotate_registers = true -+ -+(* Representation of hard registers by pseudo-registers *) -+ -+let hard_int_reg = -+ let v = Array.create 28 Reg.dummy in -+ for i = 0 to 27 do -+ v.(i) <- Reg.at_location Int (Reg i) -+ done; -+ v -+ -+let hard_float_reg = -+ let v = Array.create 32 Reg.dummy in -+ for i = 0 to 31 do -+ v.(i) <- Reg.at_location Float (Reg(100 + i)) -+ done; -+ v -+ -+let all_phys_regs = -+ Array.append hard_int_reg hard_float_reg -+ -+let phys_reg n = -+ if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) -+ -+let reg_x15 = phys_reg 15 -+let reg_d7 = phys_reg 107 -+ -+let stack_slot slot ty = -+ Reg.at_location ty (Stack slot) -+ -+(* Calling conventions *) -+ -+let calling_conventions -+ first_int last_int first_float last_float make_stack arg = -+ let loc = Array.create (Array.length arg) Reg.dummy in -+ let int = ref first_int in -+ let float = ref first_float in -+ let ofs = ref 0 in -+ for i = 0 to Array.length arg - 1 do -+ match arg.(i).typ with -+ Int | Addr as ty -> -+ if !int <= last_int then begin -+ loc.(i) <- phys_reg !int; -+ incr int -+ end else begin -+ loc.(i) <- stack_slot (make_stack !ofs) ty; -+ ofs := !ofs + size_int -+ end -+ | Float -> -+ if !float <= last_float then begin -+ loc.(i) <- phys_reg !float; -+ incr float -+ end else begin -+ loc.(i) <- stack_slot (make_stack !ofs) Float; -+ ofs := !ofs + size_float -+ end -+ done; -+ (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) -+ -+let incoming ofs = Incoming ofs -+let outgoing ofs = Outgoing ofs -+let not_supported ofs = fatal_error "Proc.loc_results: cannot call" -+ -+(* OCaml calling convention: -+ first integer args in r0...r15 -+ first float args in d0...d15 -+ remaining args on stack. -+ Return values in r0...r15 or d0...d15. *) -+ -+let loc_arguments arg = -+ calling_conventions 0 15 100 115 outgoing arg -+let loc_parameters arg = -+ let (loc, _) = calling_conventions 0 15 100 115 incoming arg in loc -+let loc_results res = -+ let (loc, _) = calling_conventions 0 15 100 115 not_supported res in loc -+ -+(* C calling convention: -+ first integer args in r0...r7 -+ first float args in d0...d7 -+ remaining args on stack. -+ Return values in r0...r1 or d0. *) -+ -+let loc_external_arguments arg = -+ calling_conventions 0 7 100 107 outgoing arg -+let loc_external_results res = -+ let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc -+ -+let loc_exn_bucket = phys_reg 0 -+ -+(* Registers destroyed by operations *) -+ -+let destroyed_at_c_call = -+ (* x19-x28, d8-d15 preserved *) -+ Array.of_list (List.map phys_reg -+ [0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15; -+ 100;101;102;103;104;105;106;107; -+ 116;117;118;119;120;121;122;123; -+ 124;125;126;127;128;129;130;131]) -+ -+let destroyed_at_oper = function -+ | Iop(Icall_ind | Icall_imm _) | Iop(Iextcall(_, true)) -> -+ all_phys_regs -+ | Iop(Iextcall(_, false)) -> -+ destroyed_at_c_call -+ | Iop(Ialloc _) -> -+ [| reg_x15 |] -+ | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> -+ [| reg_d7 |] (* d7 / s7 destroyed *) -+ | _ -> [||] -+ -+let destroyed_at_raise = all_phys_regs -+ -+(* Maximal register pressure *) -+ -+let safe_register_pressure = function -+ | Iextcall(_, _) -> 8 -+ | Ialloc _ -> 25 -+ | _ -> 26 -+ -+let max_register_pressure = function -+ | Iextcall(_, _) -> [| 10; 8 |] -+ | Ialloc _ -> [| 25; 32 |] -+ | Iintoffloat | Ifloatofint -+ | Iload(Single, _) | Istore(Single, _) -> [| 26; 31 |] -+ | _ -> [| 26; 32 |] -+ -+(* Layout of the stack *) -+ -+let num_stack_slots = [| 0; 0 |] -+let contains_calls = ref false -+ -+(* Calling the assembler *) -+ -+let assemble_file infile outfile = -+ Ccomp.command (Config.asm ^ " -o " ^ -+ Filename.quote outfile ^ " " ^ Filename.quote infile) -+ -+ -+let init () = () -diff --git a/asmcomp/arm64/reload.ml b/asmcomp/arm64/reload.ml -new file mode 100644 -index 0000000..ff9214e ---- /dev/null -+++ b/asmcomp/arm64/reload.ml -@@ -0,0 +1,16 @@ -+(***********************************************************************) -+(* *) -+(* OCaml *) -+(* *) -+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -+(* *) -+(* Copyright 2013 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Reloading for the ARM 64 bits *) -+ -+let fundecl f = -+ (new Reloadgen.reload_generic)#fundecl f -diff --git a/asmcomp/arm64/scheduling.ml b/asmcomp/arm64/scheduling.ml -new file mode 100644 -index 0000000..cc244be ---- /dev/null -+++ b/asmcomp/arm64/scheduling.ml -@@ -0,0 +1,18 @@ -+(***********************************************************************) -+(* *) -+(* OCaml *) -+(* *) -+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -+(* *) -+(* Copyright 2013 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+let _ = let module M = Schedgen in () (* to create a dependency *) -+ -+(* Scheduling is turned off because the processor schedules dynamically -+ much better than what we could do. *) -+ -+let fundecl f = f -diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml -new file mode 100644 -index 0000000..c74b282 ---- /dev/null -+++ b/asmcomp/arm64/selection.ml -@@ -0,0 +1,265 @@ -+(***********************************************************************) -+(* *) -+(* OCaml *) -+(* *) -+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -+(* Benedikt Meurer, University of Siegen *) -+(* *) -+(* Copyright 2013 Institut National de Recherche en Informatique *) -+(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) -+(* reserved. This file is distributed under the terms of the Q *) -+(* Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Instruction selection for the ARM processor *) -+ -+open Arch -+open Cmm -+open Mach -+ -+let is_offset chunk n = -+ (n >= -256 && n <= 255) (* 9 bits signed unscaled *) -+|| (n >= 0 && -+ match chunk with (* 12 bits unsigned, scaled by chunk size *) -+ | Byte_unsigned | Byte_signed -> -+ n < 0x1000 -+ | Sixteen_unsigned | Sixteen_signed -> -+ n land 1 = 0 && n lsr 1 < 0x1000 -+ | Thirtytwo_unsigned | Thirtytwo_signed | Single -> -+ n land 3 = 0 && n lsr 2 < 0x1000 -+ | Word | Double | Double_u -> -+ n land 7 = 0 && n lsr 3 < 0x1000) -+ -+(* An automaton to recognize ( 0+1+0* | 1+0+1* ) -+ -+ 0 1 0 -+ / \ / \ / \ -+ \ / \ / \ / -+ -0--> [1] --1--> [2] --0--> [3] -+ / -+ [0] -+ \ -+ -1--> [4] --0--> [5] --1--> [6] -+ / \ / \ / \ -+ \ / \ / \ / -+ 1 0 1 -+ -+The accepting states are 2, 3, 5 and 6. *) -+ -+let auto_table = [| (* accepting?, next on 0, next on 1 *) -+ (* state 0 *) (false, 1, 4); -+ (* state 1 *) (false, 1, 2); -+ (* state 2 *) (true, 3, 2); -+ (* state 3 *) (true, 3, 7); -+ (* state 4 *) (false, 5, 4); -+ (* state 5 *) (true, 5, 6); -+ (* state 6 *) (true, 7, 6); -+ (* state 7 *) (false, 7, 7) (* error state *) -+|] -+ -+let rec run_automata nbits state input = -+ let (acc, next0, next1) = auto_table.(state) in -+ if nbits <= 0 -+ then acc -+ else run_automata (nbits - 1) -+ (if input land 1 = 0 then next0 else next1) -+ (input asr 1) -+ -+(* We are very conservative wrt what ARM64 supports: we don't support -+ repetitions of a 000111000 or 1110000111 pattern, just a single -+ pattern of this kind. *) -+ -+let is_logical_immediate n = -+ n <> 0 && n <> -1 && run_automata 64 0 n -+ -+let is_intconst = function -+ Cconst_int _ -> true -+ | _ -> false -+ -+let inline_ops = -+ [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap"; -+ "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ] -+ -+let use_direct_addressing symb = -+ (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit symb -+ -+(* Instruction selection *) -+ -+class selector = object(self) -+ -+inherit Selectgen.selector_generic as super -+ -+method is_immediate n = -+ let mn = -n in -+ n land 0xFFF = n || n land 0xFFF_000 = n -+ || mn land 0xFFF = mn || mn land 0xFFF_000 = mn -+ -+method! is_simple_expr = function -+ (* inlined floating-point ops are simple if their arguments are *) -+ | Cop(Cextcall(fn, _, _, _), args) when List.mem fn inline_ops -> -+ List.for_all self#is_simple_expr args -+ | e -> super#is_simple_expr e -+ -+method select_addressing chunk = function -+ | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -+ when use_direct_addressing s -> -+ (Ibased(s, n), Ctuple []) -+ | Cop(Cadda, [arg; Cconst_int n]) -+ when is_offset chunk n -> -+ (Iindexed n, arg) -+ | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -+ when is_offset chunk n -> -+ (Iindexed n, Cop(Cadda, [arg1; arg2])) -+ | Cconst_symbol s -+ when use_direct_addressing s -> -+ (Ibased(s, 0), Ctuple []) -+ | arg -> -+ (Iindexed 0, arg) -+ -+method! select_operation op args = -+ match op with -+ (* Integer addition *) -+ | Caddi | Cadda -> -+ begin match args with -+ (* Add immediate *) -+ | [arg; Cconst_int n] | [Cconst_int n; arg] when self#is_immediate n -> -+ ((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)), -+ [arg]) -+ (* Shift-add *) -+ | [arg1; Cop(Clsl, [arg2; Cconst_int n])] when n > 0 && n < 64 -> -+ (Ispecific(Ishiftarith(Ishiftadd, n)), [arg1; arg2]) -+ | [arg1; Cop(Casr, [arg2; Cconst_int n])] when n > 0 && n < 64 -> -+ (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg1; arg2]) -+ | [Cop(Clsl, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> -+ (Ispecific(Ishiftarith(Ishiftadd, n)), [arg2; arg1]) -+ | [Cop(Casr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> -+ (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg2; arg1]) -+ (* Multiply-add *) -+ | [arg1; Cop(Cmuli, args2)] | [Cop(Cmuli, args2); arg1] -> -+ begin match self#select_operation Cmuli args2 with -+ | (Iintop_imm(Ilsl, l), [arg3]) -> -+ (Ispecific(Ishiftarith(Ishiftadd, l)), [arg1; arg3]) -+ | (Iintop Imul, [arg3; arg4]) -> -+ (Ispecific Imuladd, [arg3; arg4; arg1]) -+ | _ -> -+ super#select_operation op args -+ end -+ | _ -> -+ super#select_operation op args -+ end -+ (* Integer subtraction *) -+ | Csubi | Csuba -> -+ begin match args with -+ (* Sub immediate *) -+ | [arg; Cconst_int n] when self#is_immediate n -> -+ ((if n >= 0 then Iintop_imm(Isub, n) else Iintop_imm(Iadd, -n)), -+ [arg]) -+ (* Shift-sub *) -+ | [arg1; Cop(Clsl, [arg2; Cconst_int n])] when n > 0 && n < 64 -> -+ (Ispecific(Ishiftarith(Ishiftsub, n)), [arg1; arg2]) -+ | [arg1; Cop(Casr, [arg2; Cconst_int n])] when n > 0 && n < 64 -> -+ (Ispecific(Ishiftarith(Ishiftsub, -n)), [arg1; arg2]) -+ (* Multiply-sub *) -+ | [arg1; Cop(Cmuli, args2)] -> -+ begin match self#select_operation Cmuli args2 with -+ | (Iintop_imm(Ilsl, l), [arg3]) -> -+ (Ispecific(Ishiftarith(Ishiftsub, l)), [arg1; arg3]) -+ | (Iintop Imul, [arg3; arg4]) -> -+ (Ispecific Imulsub, [arg3; arg4; arg1]) -+ | _ -> -+ super#select_operation op args -+ end -+ | _ -> -+ super#select_operation op args -+ end -+ (* Checkbounds *) -+ | Ccheckbound _ -> -+ begin match args with -+ | [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> -+ (Ispecific(Ishiftcheckbound n), [arg1; arg2]) -+ | _ -> -+ super#select_operation op args -+ end -+ (* Integer multiplication *) -+ (* ARM does not support immediate operands for multiplication *) -+ | Cmuli -> -+ begin match args with -+ | [arg; Cconst_int n] | [Cconst_int n; arg] -> -+ let l = Misc.log2 n in -+ if n = 1 lsl l -+ then (Iintop_imm(Ilsl, l), [arg]) -+ else (Iintop Imul, args) -+ | _ -> -+ (Iintop Imul, args) -+ end -+ (* Division and modulus *) -+ (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) -+ | Cdivi -> -+ begin match args with -+ | [arg; Cconst_int n] when n = 1 lsl Misc.log2 n -> -+ ((if n = 1 then Imove else Iintop_imm(Idiv, n)), [arg]) -+ | _ -> -+ (Iintop Idiv, args) -+ end -+ | Cmodi -> -+ begin match args with -+ | [arg; Cconst_int n] when n = 1 lsl Misc.log2 n -> -+ ((if n = 1 then Iconst_int 0n else Iintop_imm(Imod, n)), [arg]) -+ | _ -> -+ (Iintop Imod, args) -+ end -+ (* Bitwise logical operations have a different range of immediate -+ operands than the other instructions *) -+ | Cand -> self#select_logical Iand args -+ | Cor -> self#select_logical Ior args -+ | Cxor -> self#select_logical Ixor args -+ (* Recognize floating-point negate and multiply *) -+ | Cnegf -> -+ begin match args with -+ | [Cop(Cmulf, args)] -> (Ispecific Inegmulf, args) -+ | _ -> super#select_operation op args -+ end -+ (* Recognize floating-point multiply and add/sub *) -+ | Caddf -> -+ begin match args with -+ | [arg; Cop(Cmulf, args)] | [Cop(Cmulf, args); arg] -> -+ (Ispecific Imuladdf, arg :: args) -+ | _ -> -+ super#select_operation op args -+ end -+ | Csubf -> -+ begin match args with -+ | [arg; Cop(Cmulf, args)] -> -+ (Ispecific Imulsubf, arg :: args) -+ | [Cop(Cmulf, args); arg] -> -+ (Ispecific Inegmulsubf, arg :: args) -+ | _ -> -+ super#select_operation op args -+ end -+ (* Recognize floating-point square root *) -+ | Cextcall("sqrt", _, _, _) -> -+ (Ispecific Isqrtf, args) -+ (* Recognize bswap instructions *) -+ | Cextcall("caml_bswap16_direct", _, _, _) -> -+ (Ispecific(Ibswap 16), args) -+ | Cextcall("caml_int32_direct_bswap", _, _, _) -> -+ (Ispecific(Ibswap 32), args) -+ | Cextcall(("caml_int64_direct_bswap"|"caml_nativeint_direct_bswap"), -+ _, _, _) -> -+ (Ispecific (Ibswap 64), args) -+ (* Other operations are regular *) -+ | _ -> -+ super#select_operation op args -+ -+method select_logical op = function -+ | [arg; Cconst_int n] when is_logical_immediate n -> -+ (Iintop_imm(op, n), [arg]) -+ | [Cconst_int n; arg] when is_logical_immediate n -> -+ (Iintop_imm(op, n), [arg]) -+ | args -> -+ (Iintop op, args) -+ -+end -+ -+let fundecl f = (new selector)#emit_fundecl f -diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml -index 17870c9..280b131 100644 ---- a/asmcomp/compilenv.ml -+++ b/asmcomp/compilenv.ml -@@ -83,6 +83,15 @@ let make_symbol ?(unitname = current_unit.ui_symbol) idopt = - | None -> prefix - | Some id -> prefix ^ "__" ^ id - -+let symbol_in_current_unit name = -+ let prefix = "caml" ^ current_unit.ui_symbol in -+ name = prefix || -+ (let lp = String.length prefix in -+ String.length name >= 2 + lp -+ && String.sub name 0 lp = prefix -+ && name.[lp] = '_' -+ && name.[lp + 1] = '_') -+ - let read_unit_info filename = - let ic = open_in_bin filename in - try -diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli -index 51cb8c6..9ffb145 100644 ---- a/asmcomp/compilenv.mli -+++ b/asmcomp/compilenv.mli -@@ -31,6 +31,10 @@ val make_symbol: ?unitname:string -> string option -> string - corresponds to symbol [id] in the compilation unit [u] - (or the current unit). *) - -+val symbol_in_current_unit: string -> bool -+ (* Return true if the given asm symbol belongs to the -+ current compilation unit, false otherwise. *) -+ - val symbol_for_global: Ident.t -> string - (* Return the asm symbol that refers to the given global identifier *) - -diff --git a/asmrun/arm64.S b/asmrun/arm64.S -new file mode 100644 -index 0000000..de670e6 ---- /dev/null -+++ b/asmrun/arm64.S -@@ -0,0 +1,535 @@ -+/***********************************************************************/ -+/* */ -+/* OCaml */ -+/* */ -+/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ -+/* */ -+/* Copyright 2013 Institut National de Recherche en Informatique et */ -+/* en Automatique. All rights reserved. This file is distributed */ -+/* under the terms of the GNU Library General Public License, with */ -+/* the special exception on linking described in file ../LICENSE. */ -+/* */ -+/***********************************************************************/ -+ -+/* Asm part of the runtime system, ARM processor, 64-bit mode */ -+/* Must be preprocessed by cpp */ -+ -+/* Special registers */ -+ -+#define TRAP_PTR x26 -+#define ALLOC_PTR x27 -+#define ALLOC_LIMIT x28 -+#define ARG x15 -+#define TMP x16 -+#define TMP2 x17 -+ -+/* Support for CFI directives */ -+ -+#if defined(ASM_CFI_SUPPORTED) -+#define CFI_STARTPROC .cfi_startproc -+#define CFI_ENDPROC .cfi_endproc -+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n -+#else -+#define CFI_STARTPROC -+#define CFI_ENDPROC -+#define CFI_ADJUST(n) -+#endif -+ -+/* Support for profiling with gprof */ -+ -+#define PROFILE -+ -+/* Macros to load and store global variables. Destroy TMP2 */ -+ -+#if defined(__PIC__) -+ -+#define ADDRGLOBAL(reg,symb) \ -+ adrp TMP2, :got:symb; \ -+ ldr reg, [TMP2, #:got_lo12:symb] -+ -+#define LOADGLOBAL(reg,symb) \ -+ ADDRGLOBAL(TMP2,symb); \ -+ ldr reg, [TMP2] -+ -+#define STOREGLOBAL(reg,symb) \ -+ ADDRGLOBAL(TMP2,symb); \ -+ str reg, [TMP2] -+ -+#else -+ -+#define ADDRGLOBAL(reg,symb) \ -+ adrp reg, symb; \ -+ add reg, reg, #:lo12:symb -+ -+#define LOADGLOBAL(reg,symb) \ -+ adrp TMP2, symb; \ -+ ldr reg, [TMP2, #:lo12:symb] -+ -+#define STOREGLOBAL(reg,symb) \ -+ adrp TMP2, symb; \ -+ str reg, [TMP2, #:lo12:symb] -+ -+#endif -+ -+/* Allocation functions and GC interface */ -+ -+ .globl caml_system__code_begin -+caml_system__code_begin: -+ -+ .align 2 -+ .globl caml_call_gc -+caml_call_gc: -+ CFI_STARTPROC -+ PROFILE -+ /* Record return address */ -+ STOREGLOBAL(x30, caml_last_return_address) -+.Lcaml_call_gc: -+ /* Record lowest stack address */ -+ mov TMP, sp -+ STOREGLOBAL(TMP, caml_bottom_of_stack) -+ /* Set up stack space, saving return address and frame pointer */ -+ /* (2 regs RA/GP, 24 allocatable int regs, 24 caller-save float regs) * 8 */ -+ stp x29, x30, [sp, -400]! -+ CFI_ADJUST(400) -+ add x29, sp, #0 -+ /* Save allocatable integer registers on the stack, in the order -+ given in proc.ml */ -+ stp x0, x1, [sp, 16] -+ stp x2, x3, [sp, 32] -+ stp x4, x5, [sp, 48] -+ stp x6, x7, [sp, 64] -+ stp x8, x9, [sp, 80] -+ stp x10, x11, [sp, 96] -+ stp x12, x13, [sp, 112] -+ stp x14, x15, [sp, 128] -+ stp x19, x20, [sp, 144] -+ stp x21, x22, [sp, 160] -+ stp x23, x24, [sp, 176] -+ str x25, [sp, 192] -+ /* Save caller-save floating-point registers on the stack -+ (callee-saves are preserved by caml_garbage_collection) */ -+ stp d0, d1, [sp, 208] -+ stp d2, d3, [sp, 224] -+ stp d4, d5, [sp, 240] -+ stp d6, d7, [sp, 256] -+ stp d16, d17, [sp, 272] -+ stp d18, d19, [sp, 288] -+ stp d20, d21, [sp, 304] -+ stp d22, d23, [sp, 320] -+ stp d24, d25, [sp, 336] -+ stp d26, d27, [sp, 352] -+ stp d28, d29, [sp, 368] -+ stp d30, d31, [sp, 384] -+ /* Store pointer to saved integer registers in caml_gc_regs */ -+ add TMP, sp, #16 -+ STOREGLOBAL(TMP, caml_gc_regs) -+ /* Save current allocation pointer for debugging purposes */ -+ STOREGLOBAL(ALLOC_PTR, caml_young_ptr) -+ /* Save trap pointer in case an exception is raised during GC */ -+ STOREGLOBAL(TRAP_PTR, caml_exception_pointer) -+ /* Call the garbage collector */ -+ bl caml_garbage_collection -+ /* Restore registers */ -+ ldp x0, x1, [sp, 16] -+ ldp x2, x3, [sp, 32] -+ ldp x4, x5, [sp, 48] -+ ldp x6, x7, [sp, 64] -+ ldp x8, x9, [sp, 80] -+ ldp x10, x11, [sp, 96] -+ ldp x12, x13, [sp, 112] -+ ldp x14, x15, [sp, 128] -+ ldp x19, x20, [sp, 144] -+ ldp x21, x22, [sp, 160] -+ ldp x23, x24, [sp, 176] -+ ldr x25, [sp, 192] -+ ldp d0, d1, [sp, 208] -+ ldp d2, d3, [sp, 224] -+ ldp d4, d5, [sp, 240] -+ ldp d6, d7, [sp, 256] -+ ldp d16, d17, [sp, 272] -+ ldp d18, d19, [sp, 288] -+ ldp d20, d21, [sp, 304] -+ ldp d22, d23, [sp, 320] -+ ldp d24, d25, [sp, 336] -+ ldp d26, d27, [sp, 352] -+ ldp d28, d29, [sp, 368] -+ ldp d30, d31, [sp, 384] -+ /* Reload new allocation pointer and allocation limit */ -+ LOADGLOBAL(ALLOC_PTR, caml_young_ptr) -+ LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) -+ /* Free stack space and return to caller */ -+ ldp x29, x30, [sp], 400 -+ ret -+ CFI_ENDPROC -+ .type caml_call_gc, %function -+ .size caml_call_gc, .-caml_call_gc -+ -+ .align 2 -+ .globl caml_alloc1 -+caml_alloc1: -+ CFI_STARTPROC -+ PROFILE -+1: sub ALLOC_PTR, ALLOC_PTR, #16 -+ cmp ALLOC_PTR, ALLOC_LIMIT -+ b.lo 2f -+ ret -+2: stp x29, x30, [sp, -16]! -+ CFI_ADJUST(16) -+ add x29, sp, #0 -+ /* Record return address */ -+ STOREGLOBAL(x30, caml_last_return_address) -+ /* Call GC */ -+ bl .Lcaml_call_gc -+ /* Restore return address */ -+ ldp x29, x30, [sp], 16 -+ CFI_ADJUST(-16) -+ /* Try again */ -+ b 1b -+ CFI_ENDPROC -+ .type caml_alloc1, %function -+ .size caml_alloc1, .-caml_alloc1 -+ -+ .align 2 -+ .globl caml_alloc2 -+caml_alloc2: -+ CFI_STARTPROC -+ PROFILE -+1: sub ALLOC_PTR, ALLOC_PTR, #24 -+ cmp ALLOC_PTR, ALLOC_LIMIT -+ b.lo 2f -+ ret -+2: stp x29, x30, [sp, -16]! -+ CFI_ADJUST(16) -+ add x29, sp, #0 -+ /* Record return address */ -+ STOREGLOBAL(x30, caml_last_return_address) -+ /* Call GC */ -+ bl .Lcaml_call_gc -+ /* Restore return address */ -+ ldp x29, x30, [sp], 16 -+ CFI_ADJUST(-16) -+ /* Try again */ -+ b 1b -+ CFI_ENDPROC -+ .type caml_alloc2, %function -+ .size caml_alloc2, .-caml_alloc2 -+ -+ .align 2 -+ .globl caml_alloc3 -+caml_alloc3: -+ CFI_STARTPROC -+ PROFILE -+1: sub ALLOC_PTR, ALLOC_PTR, #32 -+ cmp ALLOC_PTR, ALLOC_LIMIT -+ b.lo 2f -+ ret -+2: stp x29, x30, [sp, -16]! -+ CFI_ADJUST(16) -+ add x29, sp, #0 -+ /* Record return address */ -+ STOREGLOBAL(x30, caml_last_return_address) -+ /* Call GC */ -+ bl .Lcaml_call_gc -+ /* Restore return address */ -+ ldp x29, x30, [sp], 16 -+ CFI_ADJUST(-16) -+ /* Try again */ -+ b 1b -+ CFI_ENDPROC -+ .type caml_alloc2, %function -+ .size caml_alloc2, .-caml_alloc2 -+ -+ .align 2 -+ .globl caml_allocN -+caml_allocN: -+ CFI_STARTPROC -+ PROFILE -+1: sub ALLOC_PTR, ALLOC_PTR, ARG -+ cmp ALLOC_PTR, ALLOC_LIMIT -+ b.lo 2f -+ ret -+2: stp x29, x30, [sp, -16]! -+ CFI_ADJUST(16) -+ add x29, sp, #0 -+ /* Record return address */ -+ STOREGLOBAL(x30, caml_last_return_address) -+ /* Call GC. This preserves ARG */ -+ bl .Lcaml_call_gc -+ /* Restore return address */ -+ ldp x29, x30, [sp], 16 -+ CFI_ADJUST(-16) -+ /* Try again */ -+ b 1b -+ CFI_ENDPROC -+ .type caml_allocN, %function -+ .size caml_allocN, .-caml_allocN -+ -+/* Call a C function from OCaml */ -+/* Function to call is in ARG */ -+ -+ .align 2 -+ .globl caml_c_call -+caml_c_call: -+ CFI_STARTPROC -+ PROFILE -+ /* Preserve return address in callee-save register x19 */ -+ mov x19, x30 -+ /* Record lowest stack address and return address */ -+ STOREGLOBAL(x30, caml_last_return_address) -+ add TMP, sp, #0 -+ STOREGLOBAL(TMP, caml_bottom_of_stack) -+ /* Make the exception handler alloc ptr available to the C code */ -+ STOREGLOBAL(ALLOC_PTR, caml_young_ptr) -+ STOREGLOBAL(TRAP_PTR, caml_exception_pointer) -+ /* Call the function */ -+ blr ARG -+ /* Reload alloc ptr and alloc limit */ -+ LOADGLOBAL(ALLOC_PTR, caml_young_ptr) -+ LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) -+ /* Return */ -+ ret x19 -+ CFI_ENDPROC -+ .type caml_c_call, %function -+ .size caml_c_call, .-caml_c_call -+ -+/* Start the OCaml program */ -+ -+ .align 2 -+ .globl caml_start_program -+caml_start_program: -+ CFI_STARTPROC -+ PROFILE -+ ADDRGLOBAL(ARG, caml_program) -+ -+/* Code shared with caml_callback* */ -+/* Address of OCaml code to call is in ARG */ -+/* Arguments to the OCaml code are in x0...x7 */ -+ -+.Ljump_to_caml: -+ /* Set up stack frame and save callee-save registers */ -+ stp x29, x30, [sp, -160]! -+ CFI_ADJUST(160) -+ add x29, sp, #0 -+ stp x19, x20, [sp, 16] -+ stp x21, x22, [sp, 32] -+ stp x23, x24, [sp, 48] -+ stp x25, x26, [sp, 64] -+ stp x27, x28, [sp, 80] -+ stp d8, d9, [sp, 96] -+ stp d10, d11, [sp, 112] -+ stp d12, d13, [sp, 128] -+ stp d14, d15, [sp, 144] -+ /* Setup a callback link on the stack */ -+ LOADGLOBAL(x8, caml_bottom_of_stack) -+ LOADGLOBAL(x9, caml_last_return_address) -+ LOADGLOBAL(x10, caml_gc_regs) -+ stp x8, x9, [sp, -32]! /* 16-byte alignment */ -+ CFI_ADJUST(32) -+ str x10, [sp, 16] -+ /* Setup a trap frame to catch exceptions escaping the OCaml code */ -+ LOADGLOBAL(x8, caml_exception_pointer) -+ adr x9, .Ltrap_handler -+ stp x8, x9, [sp, -16]! -+ CFI_ADJUST(16) -+ add TRAP_PTR, sp, #0 -+ /* Reload allocation pointers */ -+ LOADGLOBAL(ALLOC_PTR, caml_young_ptr) -+ LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) -+ /* Call the OCaml code */ -+ blr ARG -+.Lcaml_retaddr: -+ /* Pop the trap frame, restoring caml_exception_pointer */ -+ ldr x8, [sp], 16 -+ CFI_ADJUST(-16) -+ STOREGLOBAL(x8, caml_exception_pointer) -+ /* Pop the callback link, restoring the global variables */ -+.Lreturn_result: -+ ldr x10, [sp, 16] -+ ldp x8, x9, [sp], 32 -+ CFI_ADJUST(-32) -+ STOREGLOBAL(x8, caml_bottom_of_stack) -+ STOREGLOBAL(x9, caml_last_return_address) -+ STOREGLOBAL(x10, caml_gc_regs) -+ /* Update allocation pointer */ -+ STOREGLOBAL(ALLOC_PTR, caml_young_ptr) -+ /* Reload callee-save registers and return address */ -+ ldp x19, x20, [sp, 16] -+ ldp x21, x22, [sp, 32] -+ ldp x23, x24, [sp, 48] -+ ldp x25, x26, [sp, 64] -+ ldp x27, x28, [sp, 80] -+ ldp d8, d9, [sp, 96] -+ ldp d10, d11, [sp, 112] -+ ldp d12, d13, [sp, 128] -+ ldp d14, d15, [sp, 144] -+ ldp x29, x30, [sp], 160 -+ CFI_ADJUST(-160) -+ /* Return to C caller */ -+ ret -+ CFI_ENDPROC -+ .type .Lcaml_retaddr, %function -+ .size .Lcaml_retaddr, .-.Lcaml_retaddr -+ .type caml_start_program, %function -+ .size caml_start_program, .-caml_start_program -+ -+/* The trap handler */ -+ -+ .align 2 -+.Ltrap_handler: -+ CFI_STARTPROC -+ /* Save exception pointer */ -+ STOREGLOBAL(TRAP_PTR, caml_exception_pointer) -+ /* Encode exception bucket as an exception result */ -+ orr x0, x0, #2 -+ /* Return it */ -+ b .Lreturn_result -+ CFI_ENDPROC -+ .type .Ltrap_handler, %function -+ .size .Ltrap_handler, .-.Ltrap_handler -+ -+/* Raise an exception from OCaml */ -+ -+ .align 2 -+ .globl caml_raise_exn -+caml_raise_exn: -+ CFI_STARTPROC -+ PROFILE -+ /* Test if backtrace is active */ -+ LOADGLOBAL(TMP, caml_backtrace_active) -+ cbnz TMP, 2f -+1: /* Cut stack at current trap handler */ -+ mov sp, TRAP_PTR -+ /* Pop previous handler and jump to it */ -+ ldr TMP, [sp, 8] -+ ldr TRAP_PTR, [sp], 16 -+ br TMP -+2: /* Preserve exception bucket in callee-save register x19 */ -+ mov x19, x0 -+ /* Stash the backtrace */ -+ /* arg1: exn bucket, already in x0 */ -+ mov x1, x30 /* arg2: pc of raise */ -+ add x2, sp, #0 /* arg3: sp of raise */ -+ mov x3, TRAP_PTR /* arg4: sp of handler */ -+ bl caml_stash_backtrace -+ /* Restore exception bucket and raise */ -+ mov x0, x19 -+ b 1b -+ CFI_ENDPROC -+ .type caml_raise_exn, %function -+ .size caml_raise_exn, .-caml_raise_exn -+ -+/* Raise an exception from C */ -+ -+ .align 2 -+ .globl caml_raise_exception -+caml_raise_exception: -+ CFI_STARTPROC -+ PROFILE -+ /* Reload trap ptr, alloc ptr and alloc limit */ -+ LOADGLOBAL(TRAP_PTR, caml_exception_pointer) -+ LOADGLOBAL(ALLOC_PTR, caml_young_ptr) -+ LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) -+ /* Test if backtrace is active */ -+ LOADGLOBAL(TMP, caml_backtrace_active) -+ cbnz TMP, 2f -+1: /* Cut stack at current trap handler */ -+ mov sp, TRAP_PTR -+ /* Pop previous handler and jump to it */ -+ ldr TMP, [sp, 8] -+ ldr TRAP_PTR, [sp], 16 -+ br TMP -+2: /* Preserve exception bucket in callee-save register x19 */ -+ mov x19, x0 -+ /* Stash the backtrace */ -+ /* arg1: exn bucket, already in x0 */ -+ LOADGLOBAL(x1, caml_last_return_address) /* arg2: pc of raise */ -+ LOADGLOBAL(x2, caml_bottom_of_stack) /* arg3: sp of raise */ -+ mov x3, TRAP_PTR /* arg4: sp of handler */ -+ bl caml_stash_backtrace -+ /* Restore exception bucket and raise */ -+ mov x0, x19 -+ b 1b -+ CFI_ENDPROC -+ .type caml_raise_exception, %function -+ .size caml_raise_exception, .-caml_raise_exception -+ -+/* Callback from C to OCaml */ -+ -+ .align 2 -+ .globl caml_callback_exn -+caml_callback_exn: -+ CFI_STARTPROC -+ PROFILE -+ /* Initial shuffling of arguments (x0 = closure, x1 = first arg) */ -+ mov TMP, x0 -+ mov x0, x1 /* x0 = first arg */ -+ mov x1, TMP /* x1 = closure environment */ -+ ldr ARG, [TMP] /* code pointer */ -+ b .Ljump_to_caml -+ CFI_ENDPROC -+ .type caml_callback_exn, %function -+ .size caml_callback_exn, .-caml_callback_exn -+ -+ .align 2 -+ .globl caml_callback2_exn -+caml_callback2_exn: -+ CFI_STARTPROC -+ PROFILE -+ /* Initial shuffling of arguments (x0 = closure, x1 = arg1, x2 = arg2) */ -+ mov TMP, x0 -+ mov x0, x1 /* x0 = first arg */ -+ mov x1, x2 /* x1 = second arg -+ mov x2, TMP /* x2 = closure environment */ -+ ADDRGLOBAL(ARG, caml_apply2) -+ b .Ljump_to_caml -+ CFI_ENDPROC -+ .type caml_callback2_exn, %function -+ .size caml_callback2_exn, .-caml_callback2_exn -+ -+ .align 2 -+ .globl caml_callback3_exn -+caml_callback3_exn: -+ CFI_STARTPROC -+ PROFILE -+ /* Initial shuffling of arguments */ -+ /* (x0 = closure, x1 = arg1, x2 = arg2, x3 = arg3) */ -+ mov TMP, x0 -+ mov x0, x1 /* x0 = first arg */ -+ mov x1, x2 /* x1 = second arg */ -+ mov x2, x3 /* x2 = third arg */ -+ mov x3, TMP /* x3 = closure environment */ -+ ADDRGLOBAL(ARG, caml_apply3) -+ b .Ljump_to_caml -+ CFI_ENDPROC -+ .type caml_callback3_exn, %function -+ .size caml_callback3_exn, .-caml_callback3_exn -+ -+ .align 2 -+ .globl caml_ml_array_bound_error -+caml_ml_array_bound_error: -+ CFI_STARTPROC -+ PROFILE -+ /* Load address of [caml_array_bound_error] in ARG */ -+ ADDRGLOBAL(ARG, caml_array_bound_error) -+ /* Call that function */ -+ b caml_c_call -+ CFI_ENDPROC -+ .type caml_ml_array_bound_error, %function -+ .size caml_ml_array_bound_error, .-caml_ml_array_bound_error -+ -+ .globl caml_system__code_end -+caml_system__code_end: -+ -+/* GC roots for callback */ -+ -+ .data -+ .align 3 -+ .globl caml_system__frametable -+caml_system__frametable: -+ .quad 1 /* one descriptor */ -+ .quad .Lcaml_retaddr /* return address into callback */ -+ .short -1 /* negative frame size => use callback link */ -+ .short 0 /* no roots */ -+ .align 3 -+ .type caml_system__frametable, %object -+ .size caml_system__frametable, .-caml_system__frametable -diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h -index ff19847..68ec837 100644 ---- a/asmrun/signals_osdep.h -+++ b/asmrun/signals_osdep.h -@@ -92,6 +92,25 @@ - #define CONTEXT_YOUNG_PTR (context->uc_mcontext.arm_r8) - #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) - -+/****************** ARM64, Linux */ -+ -+#elif defined(TARGET_arm64) && defined(SYS_linux) -+ -+ #include -+ -+ #define DECLARE_SIGNAL_HANDLER(name) \ -+ static void name(int sig, siginfo_t * info, ucontext_t * context) -+ -+ #define SET_SIGACT(sigact,name) \ -+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ -+ sigact.sa_flags = SA_SIGINFO -+ -+ typedef unsigned long context_reg; -+ #define CONTEXT_PC (context->uc_mcontext.pc) -+ #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.regs[26]) -+ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.regs[27]) -+ #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) -+ - /****************** AMD64, Solaris x86 */ - - #elif defined(TARGET_amd64) && defined (SYS_solaris) -diff --git a/asmrun/stack.h b/asmrun/stack.h -index 756db95..031e408 100644 ---- a/asmrun/stack.h -+++ b/asmrun/stack.h -@@ -65,6 +65,11 @@ - #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) - #endif - -+#ifdef TARGET_arm64 -+#define Saved_return_address(sp) *((intnat *)((sp) - 8)) -+#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -+#endif -+ - /* Structure of OCaml callback contexts */ - - struct caml_context { -diff --git a/byterun/interp.c b/byterun/interp.c -index b99ed2f..af9fa0f 100644 ---- a/byterun/interp.c -+++ b/byterun/interp.c -@@ -173,6 +173,12 @@ sp is a local copy of the global variable caml_extern_sp. */ - #define SP_REG asm("%r14") - #define ACCU_REG asm("%r13") - #endif -+#ifdef __aarch64__ -+#define PC_REG asm("%x19") -+#define SP_REG asm("%x20") -+#define ACCU_REG asm("%x21") -+#define JUMPTBL_BASE_REG asm("%x22") -+#endif - #endif - - /* Division and modulus madness */ -diff --git a/configure b/configure -index 9bb9e9e..a0e1466 100755 ---- a/configure -+++ b/configure -@@ -661,6 +661,7 @@ if test $withsharedlibs = "yes"; then - x86_64-*-netbsd*) natdynlink=true;; - i386-*-gnu0.3) natdynlink=true;; - arm*-*-linux*) natdynlink=true;; -+ aarch64-*-linux*) natdynlink=true;; - esac - fi - -@@ -719,6 +720,7 @@ case "$host" in - x86_64-*-netbsd*) arch=amd64; system=netbsd;; - x86_64-*-openbsd*) arch=amd64; system=openbsd;; - x86_64-*-darwin*) arch=amd64; system=macosx;; -+ aarch64-*-linux*) arch=arm64; system=linux;; - x86_64-*-cygwin*) arch=amd64; system=cygwin;; - esac - -@@ -772,7 +774,7 @@ case "$arch,$model,$system" in - aspp='gcc -m64 -c';; - amd64,*,*) as='as' - aspp='gcc -c';; -- arm,*,*) as='as'; -+ arm,*,*|arm64,*,*)as='as'; - aspp='gcc -c';; - i386,*,solaris) as='as' - aspp='/usr/ccs/bin/as -P';; -@@ -1198,6 +1200,7 @@ case "$arch" in - fi;; - power) bng_arch=ppc; bng_asm_level=1;; - amd64) bng_arch=amd64; bng_asm_level=1;; -+ arm64) bng_arch=arm64; bng_asm_level=1;; - *) bng_arch=generic; bng_asm_level=0;; - esac - -diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c -index 5bbedb0..0483ef5 100644 ---- a/otherlibs/num/bng.c -+++ b/otherlibs/num/bng.c -@@ -23,12 +23,10 @@ - #include "bng_amd64.c" - #elif defined(BNG_ARCH_ppc) - #include "bng_ppc.c" --#elif defined (BNG_ARCH_alpha) --#include "bng_alpha.c" - #elif defined (BNG_ARCH_sparc) - #include "bng_sparc.c" --#elif defined (BNG_ARCH_mips) --#include "bng_mips.c" -+#elif defined (BNG_ARCH_arm64) -+#include "bng_arm64.c" - #endif - #endif - -diff --git a/otherlibs/num/bng_arm64.c b/otherlibs/num/bng_arm64.c -new file mode 100644 -index 0000000..50843a0 ---- /dev/null -+++ b/otherlibs/num/bng_arm64.c -@@ -0,0 +1,20 @@ -+/***********************************************************************/ -+/* */ -+/* OCaml */ -+/* */ -+/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ -+/* */ -+/* Copyright 2013 Institut National de Recherche en Informatique et */ -+/* en Automatique. All rights reserved. This file is distributed */ -+/* under the terms of the GNU Library General Public License, with */ -+/* the special exception on linking described in file ../../LICENSE. */ -+/* */ -+/***********************************************************************/ -+ -+/* Code specific for the ARM 64 (AArch64) architecture */ -+ -+#define BngMult(resh,resl,arg1,arg2) \ -+ asm("mul %0, %2, %3 \n\t" \ -+ "umulh %1, %2, %3" \ -+ : "=&r" (resl), "=&r" (resh) \ -+ : "r" (arg1), "r" (arg2)) -diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile -index 98c2e4c..15fcb7c 100644 ---- a/testsuite/tests/asmcomp/Makefile -+++ b/testsuite/tests/asmcomp/Makefile -@@ -128,7 +128,7 @@ parsecmm.mli parsecmm.ml: parsecmm.mly - lexcmm.ml: lexcmm.mll - @$(OCAMLLEX) -q lexcmm.mll - --CASES=fib tak quicksort quicksort2 soli \ -+CASES=fib tak quicksort quicksort2 soli integr \ - arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak - ARGS_fib=-DINT_INT -DFUN=fib main.c - ARGS_tak=-DUNIT_INT -DFUN=takmain main.c -diff --git a/testsuite/tests/asmcomp/arm64.S b/testsuite/tests/asmcomp/arm64.S -new file mode 100644 -index 0000000..3bb4110 ---- /dev/null -+++ b/testsuite/tests/asmcomp/arm64.S -@@ -0,0 +1,52 @@ -+/***********************************************************************/ -+/* */ -+/* OCaml */ -+/* */ -+/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ -+/* */ -+/* Copyright 2013 Institut National de Recherche en Informatique et */ -+/* en Automatique. All rights reserved. This file is distributed */ -+/* under the terms of the Q Public License version 1.0. */ -+/* */ -+/***********************************************************************/ -+ -+ .globl call_gen_code -+ .align 2 -+call_gen_code: -+ /* Set up stack frame and save callee-save registers */ -+ stp x29, x30, [sp, -160]! -+ add x29, sp, #0 -+ stp x19, x20, [sp, 16] -+ stp x21, x22, [sp, 32] -+ stp x23, x24, [sp, 48] -+ stp x25, x26, [sp, 64] -+ stp x27, x28, [sp, 80] -+ stp d8, d9, [sp, 96] -+ stp d10, d11, [sp, 112] -+ stp d12, d13, [sp, 128] -+ stp d14, d15, [sp, 144] -+ /* Shuffle arguments */ -+ mov x8, x0 -+ mov x0, x1 -+ mov x1, x2 -+ mov x2, x3 -+ mov x3, x4 -+ /* Call generated asm */ -+ blr x8 -+ /* Reload callee-save registers and return address */ -+ ldp x19, x20, [sp, 16] -+ ldp x21, x22, [sp, 32] -+ ldp x23, x24, [sp, 48] -+ ldp x25, x26, [sp, 64] -+ ldp x27, x28, [sp, 80] -+ ldp d8, d9, [sp, 96] -+ ldp d10, d11, [sp, 112] -+ ldp d12, d13, [sp, 128] -+ ldp d14, d15, [sp, 144] -+ ldp x29, x30, [sp], 160 -+ ret -+ -+ .globl caml_c_call -+ .align 2 -+caml_c_call: -+ br x15 -diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml -index d67a643..82b699e 100644 ---- a/testsuite/tests/asmcomp/main.ml -+++ b/testsuite/tests/asmcomp/main.ml -@@ -13,6 +13,7 @@ - open Clflags - - let compile_file filename = -+ Clflags.dlcode := false; - Compilenv.reset "test"; - Emit.begin_assembly(); - let ic = open_in filename in --- -1.8.3.1 - diff --git a/SOURCES/0009-Try-fix-for-andi-ori-xori-immediates-1.patch b/SOURCES/0009-Try-fix-for-andi-ori-xori-immediates-1.patch new file mode 100644 index 0000000..688970c --- /dev/null +++ b/SOURCES/0009-Try-fix-for-andi-ori-xori-immediates-1.patch @@ -0,0 +1,43 @@ +From 84a4b62e1305795f6599c91a50b6e0d9e675cbd5 Mon Sep 17 00:00:00 2001 +From: Nicolas Ojeda Bar +Date: Thu, 10 Nov 2016 14:12:53 +0100 +Subject: [PATCH 09/12] Try fix for andi/ori/xori immediates (#1) + +--- + asmcomp/riscv/selection.ml | 13 ------------- + 1 file changed, 13 deletions(-) + +diff --git a/asmcomp/riscv/selection.ml b/asmcomp/riscv/selection.ml +index 60ec5cb4e..ad2b26e9b 100644 +--- a/asmcomp/riscv/selection.ml ++++ b/asmcomp/riscv/selection.ml +@@ -36,11 +36,6 @@ method! select_operation op args = + match (op, args) with + (* RISC-V does not support immediate operands for multiply high *) + | (Cmulhi, _) -> (Iintop Imulh, args) +- (* The and, or and xor instructions have a different range of immediate +- operands than the other instructions *) +- | (Cand, _) -> self#select_logical Iand args +- | (Cor, _) -> self#select_logical Ior args +- | (Cxor, _) -> self#select_logical Ixor args + (* Recognize (neg-)mult-add and (neg-)mult-sub instructions *) + | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) + | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> +@@ -58,14 +53,6 @@ method! select_operation op args = + | _ -> + super#select_operation op args + +-method select_logical op = function +- | [arg; Cconst_int n] when n >= 0 && n <= 0xFFF -> +- (Iintop_imm(op, n), [arg]) +- | [Cconst_int n; arg] when n >= 0 && n <= 0xFFF -> +- (Iintop_imm(op, n), [arg]) +- | args -> +- (Iintop op, args) +- + (* Instruction selection for conditionals *) + + method! select_condition = function +-- +2.13.2 + diff --git a/SOURCES/0009-Updated-with-latest-versions-from-FSF.patch b/SOURCES/0009-Updated-with-latest-versions-from-FSF.patch deleted file mode 100644 index 6811bb6..0000000 --- a/SOURCES/0009-Updated-with-latest-versions-from-FSF.patch +++ /dev/null @@ -1,716 +0,0 @@ -From 77a24f7ba8023f1119454cac877285cfaef909e0 Mon Sep 17 00:00:00 2001 -From: Xavier Leroy -Date: Thu, 18 Jul 2013 16:07:25 +0000 -Subject: [PATCH 09/19] Updated with latest versions from FSF. - -git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13907 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 -(cherry picked from commit 24bb4caeb35e49126aa3a4c0101a412db1091213) ---- - config/gnu/config.guess | 196 ++++++++++++++++++++++++++++-------------------- - config/gnu/config.sub | 117 +++++++++++++++++------------ - 2 files changed, 183 insertions(+), 130 deletions(-) - -diff --git a/config/gnu/config.guess b/config/gnu/config.guess -index 8152efd..b79252d 100755 ---- a/config/gnu/config.guess -+++ b/config/gnu/config.guess -@@ -1,14 +1,12 @@ - #! /bin/sh - # Attempt to guess a canonical system name. --# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, --# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, --# 2011 Free Software Foundation, Inc. -+# Copyright 1992-2013 Free Software Foundation, Inc. - --timestamp='2011-11-11' -+timestamp='2013-06-10' - - # This file is free software; you can redistribute it and/or modify it - # under the terms of the GNU General Public License as published by --# the Free Software Foundation; either version 2 of the License, or -+# the Free Software Foundation; either version 3 of the License, or - # (at your option) any later version. - # - # This program is distributed in the hope that it will be useful, but -@@ -17,26 +15,22 @@ timestamp='2011-11-11' - # General Public License for more details. - # - # You should have received a copy of the GNU General Public License --# along with this program; if not, write to the Free Software --# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA --# 02110-1301, USA. -+# along with this program; if not, see . - # - # As a special exception to the GNU General Public License, if you - # distribute this file as part of a program that contains a - # configuration script generated by Autoconf, you may include it under --# the same distribution terms that you use for the rest of that program. -- -- --# Originally written by Per Bothner. Please send patches (context --# diff format) to and include a ChangeLog --# entry. -+# the same distribution terms that you use for the rest of that -+# program. This Exception is an additional permission under section 7 -+# of the GNU General Public License, version 3 ("GPLv3"). - # --# This script attempts to guess a canonical system name similar to --# config.sub. If it succeeds, it prints the system name on stdout, and --# exits with 0. Otherwise, it exits with 1. -+# Originally written by Per Bothner. - # - # You can get the latest version of this script from: - # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD -+# -+# Please send patches with a ChangeLog entry to config-patches@gnu.org. -+ - - me=`echo "$0" | sed -e 's,.*/,,'` - -@@ -56,9 +50,7 @@ version="\ - GNU config.guess ($timestamp) - - Originally written by Per Bothner. --Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, --2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free --Software Foundation, Inc. -+Copyright 1992-2013 Free Software Foundation, Inc. - - This is free software; see the source for copying conditions. There is NO - warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." -@@ -140,12 +132,33 @@ UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown - UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown - UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -+case "${UNAME_SYSTEM}" in -+Linux|GNU|GNU/*) -+ # If the system lacks a compiler, then just pick glibc. -+ # We could probably try harder. -+ LIBC=gnu -+ -+ eval $set_cc_for_build -+ cat <<-EOF > $dummy.c -+ #include -+ #if defined(__UCLIBC__) -+ LIBC=uclibc -+ #elif defined(__dietlibc__) -+ LIBC=dietlibc -+ #else -+ LIBC=gnu -+ #endif -+ EOF -+ eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` -+ ;; -+esac -+ - # Note: order is significant - the case branches are not exclusive. - - case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - *:NetBSD:*:*) - # NetBSD (nbsd) targets should (where applicable) match one or -- # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, -+ # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, - # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently - # switched to ELF, *-*-netbsd* would select the old - # object file format. This provides both forward -@@ -202,6 +215,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}" - exit ;; -+ *:Bitrig:*:*) -+ UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` -+ echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} -+ exit ;; - *:OpenBSD:*:*) - UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} -@@ -304,7 +321,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit ;; -- arm:riscos:*:*|arm:RISCOS:*:*) -+ arm*:riscos:*:*|arm*:RISCOS:*:*) - echo arm-unknown-riscos - exit ;; - SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) -@@ -803,6 +820,9 @@ EOF - i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin - exit ;; -+ *:MINGW64*:*) -+ echo ${UNAME_MACHINE}-pc-mingw64 -+ exit ;; - *:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit ;; -@@ -854,15 +874,22 @@ EOF - exit ;; - *:GNU:*:*) - # the GNU system -- echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` -+ echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit ;; - *:GNU/*:*:*) - # other systems with GNU libc and userland -- echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu -+ echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} - exit ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix - exit ;; -+ aarch64:Linux:*:*) -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} -+ exit ;; -+ aarch64_be:Linux:*:*) -+ UNAME_MACHINE=aarch64_be -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} -+ exit ;; - alpha:Linux:*:*) - case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in - EV5) UNAME_MACHINE=alphaev5 ;; -@@ -874,59 +901,54 @@ EOF - EV68*) UNAME_MACHINE=alphaev68 ;; - esac - objdump --private-headers /bin/sh | grep -q ld.so.1 -- if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi -- echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} -+ if test "$?" = 0 ; then LIBC="gnulibc1" ; fi -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} -+ exit ;; -+ arc:Linux:*:* | arceb:Linux:*:*) -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - arm*:Linux:*:*) - eval $set_cc_for_build - if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_EABI__ - then -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - else - if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_PCS_VFP - then -- echo ${UNAME_MACHINE}-unknown-linux-gnueabi -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi - else -- echo ${UNAME_MACHINE}-unknown-linux-gnueabihf -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf - fi - fi - exit ;; - avr32*:Linux:*:*) -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - cris:Linux:*:*) -- echo cris-axis-linux-gnu -+ echo ${UNAME_MACHINE}-axis-linux-${LIBC} - exit ;; - crisv32:Linux:*:*) -- echo crisv32-axis-linux-gnu -+ echo ${UNAME_MACHINE}-axis-linux-${LIBC} - exit ;; - frv:Linux:*:*) -- echo frv-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - hexagon:Linux:*:*) -- echo hexagon-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - i*86:Linux:*:*) -- LIBC=gnu -- eval $set_cc_for_build -- sed 's/^ //' << EOF >$dummy.c -- #ifdef __dietlibc__ -- LIBC=dietlibc -- #endif --EOF -- eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` -- echo "${UNAME_MACHINE}-pc-linux-${LIBC}" -+ echo ${UNAME_MACHINE}-pc-linux-${LIBC} - exit ;; - ia64:Linux:*:*) -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - m32r*:Linux:*:*) -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - m68*:Linux:*:*) -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - mips:Linux:*:* | mips64:Linux:*:*) - eval $set_cc_for_build -@@ -945,54 +967,63 @@ EOF - #endif - EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` -- test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } -+ test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } - ;; -+ or1k:Linux:*:*) -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} -+ exit ;; - or32:Linux:*:*) -- echo or32-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - padre:Linux:*:*) -- echo sparc-unknown-linux-gnu -+ echo sparc-unknown-linux-${LIBC} - exit ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) -- echo hppa64-unknown-linux-gnu -+ echo hppa64-unknown-linux-${LIBC} - exit ;; - parisc:Linux:*:* | hppa:Linux:*:*) - # Look for CPU level - case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in -- PA7*) echo hppa1.1-unknown-linux-gnu ;; -- PA8*) echo hppa2.0-unknown-linux-gnu ;; -- *) echo hppa-unknown-linux-gnu ;; -+ PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; -+ PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; -+ *) echo hppa-unknown-linux-${LIBC} ;; - esac - exit ;; - ppc64:Linux:*:*) -- echo powerpc64-unknown-linux-gnu -+ echo powerpc64-unknown-linux-${LIBC} - exit ;; - ppc:Linux:*:*) -- echo powerpc-unknown-linux-gnu -+ echo powerpc-unknown-linux-${LIBC} -+ exit ;; -+ ppc64le:Linux:*:*) -+ echo powerpc64le-unknown-linux-${LIBC} -+ exit ;; -+ ppcle:Linux:*:*) -+ echo powerpcle-unknown-linux-${LIBC} - exit ;; - s390:Linux:*:* | s390x:Linux:*:*) -- echo ${UNAME_MACHINE}-ibm-linux -+ echo ${UNAME_MACHINE}-ibm-linux-${LIBC} - exit ;; - sh64*:Linux:*:*) -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - sh*:Linux:*:*) -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - sparc:Linux:*:* | sparc64:Linux:*:*) -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - tile*:Linux:*:*) -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - vax:Linux:*:*) -- echo ${UNAME_MACHINE}-dec-linux-gnu -+ echo ${UNAME_MACHINE}-dec-linux-${LIBC} - exit ;; - x86_64:Linux:*:*) -- echo x86_64-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - xtensa*:Linux:*:*) -- echo ${UNAME_MACHINE}-unknown-linux-gnu -+ echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - i*86:DYNIX/ptx:4*:*) - # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. -@@ -1196,6 +1227,9 @@ EOF - BePC:Haiku:*:*) # Haiku running on Intel PC compatible. - echo i586-pc-haiku - exit ;; -+ x86_64:Haiku:*:*) -+ echo x86_64-unknown-haiku -+ exit ;; - SX-4:SUPER-UX:*:*) - echo sx4-nec-superux${UNAME_RELEASE} - exit ;; -@@ -1222,19 +1256,21 @@ EOF - exit ;; - *:Darwin:*:*) - UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown -- case $UNAME_PROCESSOR in -- i386) -- eval $set_cc_for_build -- if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then -- if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ -- (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ -- grep IS_64BIT_ARCH >/dev/null -- then -- UNAME_PROCESSOR="x86_64" -- fi -- fi ;; -- unknown) UNAME_PROCESSOR=powerpc ;; -- esac -+ eval $set_cc_for_build -+ if test "$UNAME_PROCESSOR" = unknown ; then -+ UNAME_PROCESSOR=powerpc -+ fi -+ if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then -+ if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ -+ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ -+ grep IS_64BIT_ARCH >/dev/null -+ then -+ case $UNAME_PROCESSOR in -+ i386) UNAME_PROCESSOR=x86_64 ;; -+ powerpc) UNAME_PROCESSOR=powerpc64 ;; -+ esac -+ fi -+ fi - echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} - exit ;; - *:procnto*:*:* | *:QNX:[0123456789]*:*) -@@ -1251,7 +1287,7 @@ EOF - NEO-?:NONSTOP_KERNEL:*:*) - echo neo-tandem-nsk${UNAME_RELEASE} - exit ;; -- NSE-?:NONSTOP_KERNEL:*:*) -+ NSE-*:NONSTOP_KERNEL:*:*) - echo nse-tandem-nsk${UNAME_RELEASE} - exit ;; - NSR-?:NONSTOP_KERNEL:*:*) -@@ -1320,11 +1356,11 @@ EOF - i*86:AROS:*:*) - echo ${UNAME_MACHINE}-pc-aros - exit ;; -+ x86_64:VMkernel:*:*) -+ echo ${UNAME_MACHINE}-unknown-esx -+ exit ;; - esac - --#echo '(No uname command or uname output not recognized.)' 1>&2 --#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 -- - eval $set_cc_for_build - cat >$dummy.c <. - # - # As a special exception to the GNU General Public License, if you - # distribute this file as part of a program that contains a - # configuration script generated by Autoconf, you may include it under --# the same distribution terms that you use for the rest of that program. -+# the same distribution terms that you use for the rest of that -+# program. This Exception is an additional permission under section 7 -+# of the GNU General Public License, version 3 ("GPLv3"). - - --# Please send patches to . Submit a context --# diff and a properly formatted GNU ChangeLog entry. -+# Please send patches with a ChangeLog entry to config-patches@gnu.org. - # - # Configuration subroutine to validate and canonicalize a configuration type. - # Supply the specified configuration type as an argument. -@@ -75,9 +68,7 @@ Report bugs and patches to ." - version="\ - GNU config.sub ($timestamp) - --Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, --2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free --Software Foundation, Inc. -+Copyright 1992-2013 Free Software Foundation, Inc. - - This is free software; see the source for copying conditions. There is NO - warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." -@@ -125,13 +116,17 @@ esac - maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` - case $maybe_os in - nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ -- linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ -+ linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ - knetbsd*-gnu* | netbsd*-gnu* | \ - kopensolaris*-gnu* | \ - storm-chaos* | os2-emx* | rtmk-nova*) - os=-$maybe_os - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` - ;; -+ android-linux) -+ os=-linux-android -+ basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown -+ ;; - *) - basic_machine=`echo $1 | sed 's/-[^-]*$//'` - if [ $basic_machine != $1 ] -@@ -154,7 +149,7 @@ case $os in - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -- -apple | -axis | -knuth | -cray | -microblaze) -+ -apple | -axis | -knuth | -cray | -microblaze*) - os= - basic_machine=$1 - ;; -@@ -223,6 +218,12 @@ case $os in - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; -+ -lynx*178) -+ os=-lynxos178 -+ ;; -+ -lynx*5) -+ os=-lynxos5 -+ ;; - -lynx*) - os=-lynxos - ;; -@@ -247,11 +248,14 @@ case $basic_machine in - # Some are omitted here because they have special meanings below. - 1750a | 580 \ - | a29k \ -+ | aarch64 | aarch64_be \ - | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ - | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ - | am33_2.0 \ -- | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \ -- | be32 | be64 \ -+ | arc | arceb \ -+ | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ -+ | avr | avr32 \ -+ | be32 | be64 \ - | bfin \ - | c4x | clipper \ - | d10v | d30v | dlx | dsp16xx \ -@@ -264,7 +268,7 @@ case $basic_machine in - | le32 | le64 \ - | lm32 \ - | m32c | m32r | m32rle | m68000 | m68k | m88k \ -- | maxq | mb | microblaze | mcore | mep | metag \ -+ | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ - | mips | mipsbe | mipseb | mipsel | mipsle \ - | mips16 \ - | mips64 | mips64el \ -@@ -282,16 +286,17 @@ case $basic_machine in - | mipsisa64r2 | mipsisa64r2el \ - | mipsisa64sb1 | mipsisa64sb1el \ - | mipsisa64sr71k | mipsisa64sr71kel \ -+ | mipsr5900 | mipsr5900el \ - | mipstx39 | mipstx39el \ - | mn10200 | mn10300 \ - | moxie \ - | mt \ - | msp430 \ - | nds32 | nds32le | nds32be \ -- | nios | nios2 \ -+ | nios | nios2 | nios2eb | nios2el \ - | ns16k | ns32k \ - | open8 \ -- | or32 \ -+ | or1k | or32 \ - | pdp10 | pdp11 | pj | pjl \ - | powerpc | powerpc64 | powerpc64le | powerpcle \ - | pyramid \ -@@ -319,8 +324,7 @@ case $basic_machine in - c6x) - basic_machine=tic6x-unknown - ;; -- m6811 | m68hc11 | m6812 | m68hc12 | picochip) -- # Motorola 68HC11/12. -+ m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | picochip) - basic_machine=$basic_machine-unknown - os=-none - ;; -@@ -333,7 +337,10 @@ case $basic_machine in - strongarm | thumb | xscale) - basic_machine=arm-unknown - ;; -- -+ xgate) -+ basic_machine=$basic_machine-unknown -+ os=-none -+ ;; - xscaleeb) - basic_machine=armeb-unknown - ;; -@@ -356,9 +363,10 @@ case $basic_machine in - # Recognize the basic CPU types with company name. - 580-* \ - | a29k-* \ -+ | aarch64-* | aarch64_be-* \ - | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ - | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ -- | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ -+ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ - | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ - | avr-* | avr32-* \ - | be32-* | be64-* \ -@@ -377,7 +385,8 @@ case $basic_machine in - | lm32-* \ - | m32c-* | m32r-* | m32rle-* \ - | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ -- | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \ -+ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ -+ | microblaze-* | microblazeel-* \ - | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ - | mips16-* \ - | mips64-* | mips64el-* \ -@@ -395,12 +404,13 @@ case $basic_machine in - | mipsisa64r2-* | mipsisa64r2el-* \ - | mipsisa64sb1-* | mipsisa64sb1el-* \ - | mipsisa64sr71k-* | mipsisa64sr71kel-* \ -+ | mipsr5900-* | mipsr5900el-* \ - | mipstx39-* | mipstx39el-* \ - | mmix-* \ - | mt-* \ - | msp430-* \ - | nds32-* | nds32le-* | nds32be-* \ -- | nios-* | nios2-* \ -+ | nios-* | nios2-* | nios2eb-* | nios2el-* \ - | none-* | np1-* | ns16k-* | ns32k-* \ - | open8-* \ - | orion-* \ -@@ -719,7 +729,6 @@ case $basic_machine in - i370-ibm* | ibm*) - basic_machine=i370-ibm - ;; --# I'm not sure what "Sysv32" means. Should this be sysv3.2? - i*86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv32 -@@ -777,9 +786,13 @@ case $basic_machine in - basic_machine=ns32k-utek - os=-sysv - ;; -- microblaze) -+ microblaze*) - basic_machine=microblaze-xilinx - ;; -+ mingw64) -+ basic_machine=x86_64-pc -+ os=-mingw64 -+ ;; - mingw32) - basic_machine=i386-pc - os=-mingw32 -@@ -1008,7 +1021,11 @@ case $basic_machine in - basic_machine=i586-unknown - os=-pw32 - ;; -- rdos) -+ rdos | rdos64) -+ basic_machine=x86_64-pc -+ os=-rdos -+ ;; -+ rdos32) - basic_machine=i386-pc - os=-rdos - ;; -@@ -1335,21 +1352,21 @@ case $os in - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ -- | -sym* | -kopensolaris* \ -+ | -sym* | -kopensolaris* | -plan9* \ - | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* | -aros* \ - | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ - | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ -- | -openbsd* | -solidbsd* \ -+ | -bitrig* | -openbsd* | -solidbsd* \ - | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ - | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ - | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ - | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* | -cegcc* \ - | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ -- | -mingw32* | -linux-gnu* | -linux-android* \ -- | -linux-newlib* | -linux-uclibc* \ -+ | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ -+ | -linux-newlib* | -linux-musl* | -linux-uclibc* \ - | -uxpv* | -beos* | -mpeix* | -udk* \ - | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ - | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ -@@ -1481,9 +1498,6 @@ case $os in - -aros*) - os=-aros - ;; -- -kaos*) -- os=-kaos -- ;; - -zvmoe) - os=-zvmoe - ;; -@@ -1532,6 +1546,9 @@ case $basic_machine in - c4x-* | tic4x-*) - os=-coff - ;; -+ hexagon-*) -+ os=-elf -+ ;; - tic54x-*) - os=-coff - ;; -@@ -1559,9 +1576,6 @@ case $basic_machine in - ;; - m68000-sun) - os=-sunos3 -- # This also exists in the configure program, but was not the -- # default. -- # os=-sunos4 - ;; - m68*-cisco) - os=-aout -@@ -1575,6 +1589,9 @@ case $basic_machine in - mips*-*) - os=-elf - ;; -+ or1k-*) -+ os=-elf -+ ;; - or32-*) - os=-coff - ;; --- -1.8.3.1 - diff --git a/SOURCES/0010-Fix-immediates-range-when-adjusting-indexing-sp.patch b/SOURCES/0010-Fix-immediates-range-when-adjusting-indexing-sp.patch new file mode 100644 index 0000000..9ba6686 --- /dev/null +++ b/SOURCES/0010-Fix-immediates-range-when-adjusting-indexing-sp.patch @@ -0,0 +1,156 @@ +From bf083b3beeb9a622017137c246d2cfa863056cc0 Mon Sep 17 00:00:00 2001 +From: Nicolas Ojeda Bar +Date: Tue, 22 Nov 2016 22:30:35 +0100 +Subject: [PATCH 10/12] Fix immediates' range when adjusting/indexing sp + +--- + asmcomp/riscv/arch.ml | 3 +++ + asmcomp/riscv/emit.mlp | 53 ++++++++++++++++++++++++++++++++++------------ + asmcomp/riscv/selection.ml | 2 +- + 3 files changed, 44 insertions(+), 14 deletions(-) + +diff --git a/asmcomp/riscv/arch.ml b/asmcomp/riscv/arch.ml +index 61a38b1dd..22c807c49 100644 +--- a/asmcomp/riscv/arch.ml ++++ b/asmcomp/riscv/arch.ml +@@ -32,6 +32,9 @@ let spacetime_node_hole_pointer_is_live_before = function + type addressing_mode = + | Iindexed of int (* reg + displ *) + ++let is_immediate n = ++ (n <= 2047) && (n >= -2048) ++ + (* Sizes, endianness *) + + let big_endian = false +diff --git a/asmcomp/riscv/emit.mlp b/asmcomp/riscv/emit.mlp +index 6d0e3aefd..97c49ce80 100644 +--- a/asmcomp/riscv/emit.mlp ++++ b/asmcomp/riscv/emit.mlp +@@ -93,6 +93,34 @@ let emit_stack r = + let ofs = slot_offset s (register_class r) in `{emit_int ofs}(sp)` + | _ -> fatal_error "Emit.emit_stack" + ++(* Adjust sp by the given byte amount *) ++ ++let emit_stack_adjustment = function ++ | 0 -> () ++ | n when is_immediate n -> ++ ` addi sp, sp, {emit_int n}\n` ++ | n -> ++ ` li {emit_reg reg_tmp1}, {emit_int n}\n`; ++ ` add sp, sp, {emit_reg reg_tmp1}\n` ++ ++let emit_store src ofs = ++ if is_immediate ofs then ++ ` {emit_string stg} {emit_reg src}, {emit_int ofs}(sp)\n` ++ else begin ++ ` li {emit_reg reg_tmp1}, {emit_int ofs}\n`; ++ ` add {emit_reg reg_tmp1}, sp, {emit_reg reg_tmp1}\n`; ++ ` {emit_string stg} {emit_reg src}, 0({emit_reg reg_tmp1})\n` ++ end ++ ++let emit_load dst ofs = ++ if is_immediate ofs then ++ ` {emit_string lg} {emit_reg dst}, {emit_int ofs}(sp)\n` ++ else begin ++ ` li {emit_reg reg_tmp1}, {emit_int ofs}\n`; ++ ` add {emit_reg reg_tmp1}, sp, {emit_reg reg_tmp1}\n`; ++ ` {emit_string lg} {emit_reg dst}, 0({emit_reg reg_tmp1})\n` ++ end ++ + (* Record live pointers at call points *) + + let record_frame_label ?label live raise_ dbg = +@@ -218,6 +246,7 @@ let name_for_specific = function + + (* Name of current function *) + let function_name = ref "" ++ + (* Entry point for tail recursive calls *) + let tailrec_entry_point = ref 0 + +@@ -234,12 +263,14 @@ let emit_instr i = + ` mv {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> + ` fmv.d {emit_reg dst}, {emit_reg src}\n` +- | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} -> +- ` {emit_string stg} {emit_reg src}, {emit_stack dst}\n` ++ | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack s} -> ++ let ofs = slot_offset s (register_class dst) in ++ emit_store src ofs + | {loc = Reg _; typ = Float}, {loc = Stack _} -> + ` fsd {emit_reg src}, {emit_stack dst}\n` +- | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _ } -> +- ` {emit_string lg} {emit_reg dst}, {emit_stack src}\n` ++ | {loc = Stack s; typ = (Val | Int | Addr)}, {loc = Reg _} -> ++ let ofs = slot_offset s (register_class src) in ++ emit_load dst ofs + | {loc = Stack _; typ = Float}, {loc = Reg _} -> + ` fld {emit_reg dst}, {emit_stack src}\n` + | _ -> +@@ -263,8 +294,7 @@ let emit_instr i = + let n = frame_size() in + if !contains_calls then + ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n`; +- if n > 0 then +- ` addi sp, sp, {emit_int n}\n`; ++ emit_stack_adjustment n; + ` jr {emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm {func; label_after = _}) -> + if func = !function_name then begin +@@ -273,8 +303,7 @@ let emit_instr i = + let n = frame_size() in + if !contains_calls then + ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n`; +- if n > 0 then +- ` addi sp, sp, {emit_int n}\n`; ++ emit_stack_adjustment n; + ` tail {emit_symbol func}\n` + end + | Lop(Iextcall{func; alloc = true; label_after = label}) -> +@@ -285,7 +314,7 @@ let emit_instr i = + ` call {emit_symbol func}\n` + | Lop(Istackoffset n) -> + assert (n mod 16 = 0); +- ` addi sp, sp, {emit_int (-n)}\n`; ++ emit_stack_adjustment (-n); + stack_offset := !stack_offset + n + | Lop(Iload(Single, Iindexed ofs)) -> + ` flw {emit_reg i.res.(0)}, {emit_int ofs}({emit_reg i.arg.(0)})\n`; +@@ -398,8 +427,7 @@ let emit_instr i = + ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n` + | Lreturn -> + let n = frame_size() in +- if n > 0 then +- ` addi sp, sp, {emit_int n}\n`; ++ emit_stack_adjustment n; + ` ret\n` + | Llabel lbl -> + `{emit_label lbl}:\n` +@@ -513,8 +541,7 @@ let fundecl fundecl = + ` .align 2\n`; + `{emit_symbol fundecl.fun_name}:\n`; + let n = frame_size() in +- if n > 0 then +- ` addi sp, sp, {emit_int(-n)}\n`; ++ emit_stack_adjustment (-n); + if !contains_calls then + ` {emit_string stg} ra, {emit_int(n - size_addr)}(sp)\n`; + `{emit_label !tailrec_entry_point}:\n`; +diff --git a/asmcomp/riscv/selection.ml b/asmcomp/riscv/selection.ml +index ad2b26e9b..283233679 100644 +--- a/asmcomp/riscv/selection.ml ++++ b/asmcomp/riscv/selection.ml +@@ -22,7 +22,7 @@ class selector = object (self) + + inherit Selectgen.selector_generic as super + +-method is_immediate n = (n <= 0x7FF) && (n >= -0x800) ++method is_immediate n = is_immediate n + + method select_addressing _ = function + | Cop(Cadda, [arg; Cconst_int n]) when self#is_immediate n -> +-- +2.13.2 + diff --git a/SOURCES/0010-arm64-Align-code-and-data-to-8-bytes.patch b/SOURCES/0010-arm64-Align-code-and-data-to-8-bytes.patch deleted file mode 100644 index 61af763..0000000 --- a/SOURCES/0010-arm64-Align-code-and-data-to-8-bytes.patch +++ /dev/null @@ -1,41 +0,0 @@ -From 30c30cdc0b2d0af7aa05048345f272de77aba6cb Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Mon, 24 Mar 2014 05:50:28 -0500 -Subject: [PATCH 10/19] arm64: Align code and data to 8 bytes. - -Insufficient alignment seems to be the cause of relocation errors when -linking large native code OCaml programs: - - (.text+0xc): relocation truncated to fit: R_AARCH64_LDST64_ABS_LO12_NC against symbol `camlOdoc_type' defined in .data section in odoc_type.o -../stdlib/stdlib.a(listLabels.o): In function `camlListLabels__entry': -(.text+0x10): relocation truncated to fit: R_AARCH64_LDST64_ABS_LO12_NC against symbol `camlListLabels' defined in .data section in ../stdlib/stdlib.a(listLabels.o) - -PR#6283 http://caml.inria.fr/mantis/view.php?id=6283 ---- - asmcomp/arm64/emit.mlp | 3 ++- - 1 file changed, 2 insertions(+), 1 deletion(-) - -diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp -index fc9649c..4e7c4b0 100644 ---- a/asmcomp/arm64/emit.mlp -+++ b/asmcomp/arm64/emit.mlp -@@ -651,7 +651,7 @@ let fundecl fundecl = - call_gc_sites := []; - bound_error_sites := []; - ` .text\n`; -- ` .align 2\n`; -+ ` .align 3\n`; - ` .globl {emit_symbol fundecl.fun_name}\n`; - ` .type {emit_symbol fundecl.fun_name}, %function\n`; - `{emit_symbol fundecl.fun_name}:\n`; -@@ -692,6 +692,7 @@ let emit_item = function - - let data l = - ` .data\n`; -+ ` .align 3\n`; - List.iter emit_item l - - (* Beginning / end of an assembly file *) --- -1.8.3.1 - diff --git a/SOURCES/0011-Another-immediate-range-fix.patch b/SOURCES/0011-Another-immediate-range-fix.patch new file mode 100644 index 0000000..2e2ab86 --- /dev/null +++ b/SOURCES/0011-Another-immediate-range-fix.patch @@ -0,0 +1,131 @@ +From 9e8d87c255713f7bf397083be9e6453d312c93a3 Mon Sep 17 00:00:00 2001 +From: Nicolas Ojeda Bar +Date: Wed, 23 Nov 2016 12:38:28 +0100 +Subject: [PATCH 11/12] Another immediate range fix + +--- + asmcomp/riscv/emit.mlp | 57 ++++++++++++++++++++++++++++++-------------------- + 1 file changed, 34 insertions(+), 23 deletions(-) + +diff --git a/asmcomp/riscv/emit.mlp b/asmcomp/riscv/emit.mlp +index 97c49ce80..6cc190864 100644 +--- a/asmcomp/riscv/emit.mlp ++++ b/asmcomp/riscv/emit.mlp +@@ -85,14 +85,6 @@ let emit_reg = function + | {loc = Reg r} -> emit_string (register_name r) + | _ -> fatal_error "Emit.emit_reg" + +-(* Output a stack reference *) +- +-let emit_stack r = +- match r.loc with +- Stack s -> +- let ofs = slot_offset s (register_class r) in `{emit_int ofs}(sp)` +- | _ -> fatal_error "Emit.emit_stack" +- + (* Adjust sp by the given byte amount *) + + let emit_stack_adjustment = function +@@ -103,7 +95,27 @@ let emit_stack_adjustment = function + ` li {emit_reg reg_tmp1}, {emit_int n}\n`; + ` add sp, sp, {emit_reg reg_tmp1}\n` + +-let emit_store src ofs = ++let reload_ra n = ++ let ofs = n - size_addr in ++ if is_immediate ofs then ++ ` {emit_string lg} ra, {emit_int ofs}(sp)\n` ++ else begin ++ ` li {emit_reg reg_tmp1}, {emit_int ofs}\n`; ++ ` add {emit_reg reg_tmp1}, sp, {emit_reg reg_tmp1}\n`; ++ ` {emit_string lg} ra, 0({emit_reg reg_tmp1})\n` ++ end ++ ++let store_ra n = ++ let ofs = n - size_addr in ++ if is_immediate ofs then ++ ` {emit_string stg} ra, {emit_int(n - size_addr)}(sp)\n` ++ else begin ++ ` li {emit_reg reg_tmp1}, {emit_int ofs}\n`; ++ ` add {emit_reg reg_tmp1}, sp, {emit_reg reg_tmp1}\n`; ++ ` {emit_string stg} ra, 0({emit_reg reg_tmp1})\n` ++ end ++ ++let emit_store stg src ofs = + if is_immediate ofs then + ` {emit_string stg} {emit_reg src}, {emit_int ofs}(sp)\n` + else begin +@@ -112,7 +124,7 @@ let emit_store src ofs = + ` {emit_string stg} {emit_reg src}, 0({emit_reg reg_tmp1})\n` + end + +-let emit_load dst ofs = ++let emit_load lg dst ofs = + if is_immediate ofs then + ` {emit_string lg} {emit_reg dst}, {emit_int ofs}(sp)\n` + else begin +@@ -265,14 +277,16 @@ let emit_instr i = + ` fmv.d {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack s} -> + let ofs = slot_offset s (register_class dst) in +- emit_store src ofs +- | {loc = Reg _; typ = Float}, {loc = Stack _} -> +- ` fsd {emit_reg src}, {emit_stack dst}\n` ++ emit_store stg src ofs ++ | {loc = Reg _; typ = Float}, {loc = Stack s} -> ++ let ofs = slot_offset s (register_class dst) in ++ emit_store "fsd" src ofs + | {loc = Stack s; typ = (Val | Int | Addr)}, {loc = Reg _} -> + let ofs = slot_offset s (register_class src) in +- emit_load dst ofs +- | {loc = Stack _; typ = Float}, {loc = Reg _} -> +- ` fld {emit_reg dst}, {emit_stack src}\n` ++ emit_load lg dst ofs ++ | {loc = Stack s; typ = Float}, {loc = Reg _} -> ++ let ofs = slot_offset s (register_class src) in ++ emit_load "fld" dst ofs + | _ -> + fatal_error "Emit: Imove" + end +@@ -292,8 +306,7 @@ let emit_instr i = + record_frame ~label i.live false i.dbg + | Lop(Itailcall_ind {label_after = _}) -> + let n = frame_size() in +- if !contains_calls then +- ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n`; ++ if !contains_calls then reload_ra n; + emit_stack_adjustment n; + ` jr {emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm {func; label_after = _}) -> +@@ -301,8 +314,7 @@ let emit_instr i = + ` j {emit_label !tailrec_entry_point}\n` + end else begin + let n = frame_size() in +- if !contains_calls then +- ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n`; ++ if !contains_calls then reload_ra n; + emit_stack_adjustment n; + ` tail {emit_symbol func}\n` + end +@@ -424,7 +436,7 @@ let emit_instr i = + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` + | Lreloadretaddr -> + let n = frame_size () in +- ` {emit_string lg} ra, {emit_int(n - size_addr)}(sp)\n` ++ reload_ra n + | Lreturn -> + let n = frame_size() in + emit_stack_adjustment n; +@@ -542,8 +554,7 @@ let fundecl fundecl = + `{emit_symbol fundecl.fun_name}:\n`; + let n = frame_size() in + emit_stack_adjustment (-n); +- if !contains_calls then +- ` {emit_string stg} ra, {emit_int(n - size_addr)}(sp)\n`; ++ if !contains_calls then store_ra n; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; +-- +2.13.2 + diff --git a/SOURCES/0011-arg-Add-no_arg-and-get_arg-helper-functions.patch b/SOURCES/0011-arg-Add-no_arg-and-get_arg-helper-functions.patch deleted file mode 100644 index 3a4e1a4..0000000 --- a/SOURCES/0011-arg-Add-no_arg-and-get_arg-helper-functions.patch +++ /dev/null @@ -1,118 +0,0 @@ -From c647e7cc2df2cad5a3e811dc7b3519960eb67da4 Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Tue, 1 Apr 2014 11:17:07 +0100 -Subject: [PATCH 11/19] arg: Add no_arg and get_arg helper functions. - -The no_arg function in this patch is a no-op. It will do something -useful in the followups. - -The get_arg function simply checks the next position on the command -line exists and returns that argument or raises a Arg.Missing. - -This patch should introduce no functional change, it is simply code -refactoring. - -In particular, this should not change the treatment of Arg.current -(see: http://caml.inria.fr/mantis/view.php?id=5197#c11147) ---- - stdlib/arg.ml | 47 ++++++++++++++++++++++++++--------------------- - 1 file changed, 26 insertions(+), 21 deletions(-) - -diff --git a/stdlib/arg.ml b/stdlib/arg.ml -index 8b64236..c8b3d44 100644 ---- a/stdlib/arg.ml -+++ b/stdlib/arg.ml -@@ -134,56 +134,62 @@ let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg = - try assoc3 s !speclist - with Not_found -> stop (Unknown s) - in -+ let no_arg () = () in -+ let get_arg () = -+ if !current + 1 < l then argv.(!current + 1) -+ else stop (Missing s) -+ in - begin try - let rec treat_action = function -- | Unit f -> f (); -- | Bool f when !current + 1 < l -> -- let arg = argv.(!current + 1) in -+ | Unit f -> no_arg (); f (); -+ | Bool f -> -+ let arg = get_arg () in - begin try f (bool_of_string arg) - with Invalid_argument "bool_of_string" -> - raise (Stop (Wrong (s, arg, "a boolean"))) - end; - incr current; -- | Set r -> r := true; -- | Clear r -> r := false; -- | String f when !current + 1 < l -> -- f argv.(!current + 1); -+ | Set r -> no_arg (); r := true; -+ | Clear r -> no_arg (); r := false; -+ | String f -> -+ let arg = get_arg () in -+ f arg; - incr current; -- | Symbol (symb, f) when !current + 1 < l -> -- let arg = argv.(!current + 1) in -+ | Symbol (symb, f) -> -+ let arg = get_arg () in - if List.mem arg symb then begin -- f argv.(!current + 1); -+ f arg; - incr current; - end else begin - raise (Stop (Wrong (s, arg, "one of: " - ^ (make_symlist "" " " "" symb)))) - end -- | Set_string r when !current + 1 < l -> -- r := argv.(!current + 1); -+ | Set_string r -> -+ r := get_arg (); - incr current; -- | Int f when !current + 1 < l -> -- let arg = argv.(!current + 1) in -+ | Int f -> -+ let arg = get_arg () in - begin try f (int_of_string arg) - with Failure "int_of_string" -> - raise (Stop (Wrong (s, arg, "an integer"))) - end; - incr current; -- | Set_int r when !current + 1 < l -> -- let arg = argv.(!current + 1) in -+ | Set_int r -> -+ let arg = get_arg () in - begin try r := (int_of_string arg) - with Failure "int_of_string" -> - raise (Stop (Wrong (s, arg, "an integer"))) - end; - incr current; -- | Float f when !current + 1 < l -> -- let arg = argv.(!current + 1) in -+ | Float f -> -+ let arg = get_arg () in - begin try f (float_of_string arg); - with Failure "float_of_string" -> - raise (Stop (Wrong (s, arg, "a float"))) - end; - incr current; -- | Set_float r when !current + 1 < l -> -- let arg = argv.(!current + 1) in -+ | Set_float r -> -+ let arg = get_arg () in - begin try r := (float_of_string arg); - with Failure "float_of_string" -> - raise (Stop (Wrong (s, arg, "a float"))) -@@ -196,7 +202,6 @@ let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg = - f argv.(!current + 1); - incr current; - done; -- | _ -> raise (Stop (Missing s)) - in - treat_action action - with Bad m -> stop (Message m); --- -1.8.3.1 - diff --git a/SOURCES/0012-AArch64-GOT-fixed.patch b/SOURCES/0012-AArch64-GOT-fixed.patch new file mode 100644 index 0000000..a8a5bcd --- /dev/null +++ b/SOURCES/0012-AArch64-GOT-fixed.patch @@ -0,0 +1,98 @@ +From c428a156b8e659a884d4867e52c49534125dc72f Mon Sep 17 00:00:00 2001 +From: Mark Shinwell +Date: Wed, 13 Sep 2017 10:23:16 +0100 +Subject: [PATCH 12/12] AArch64 GOT fixed + +--- + Changes | 4 ++++ + asmcomp/arm64/emit.mlp | 15 +++++++++++++-- + asmcomp/arm64/selection.ml | 4 ++-- + 3 files changed, 19 insertions(+), 4 deletions(-) + +diff --git a/Changes b/Changes +index e8dbd42e2..b84a1f30e 100644 +--- a/Changes ++++ b/Changes +@@ -150,6 +150,10 @@ OCaml 4.05.0 (13 Jul 2017): + (Hannes Mehnert, Guillaume Bury, + review by Daniel Bünzli, Gabriel Scherer, Damien Doligez) + ++- GPR#1330: when generating dynamically-linkable code on AArch64, always ++ reference symbols (even locally-defined ones) through the GOT. ++ (Mark Shinwell, review by Xavier Leroy) ++ + ### Standard library: + + - MPR#6975, GPR#902: Truncate function added to stdlib Buffer module +diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp +index f75646e12..729096c57 100644 +--- a/asmcomp/arm64/emit.mlp ++++ b/asmcomp/arm64/emit.mlp +@@ -114,6 +114,7 @@ let emit_addressing addr r = + | Iindexed ofs -> + `[{emit_reg r}, #{emit_int ofs}]` + | Ibased(s, ofs) -> ++ assert (not !Clflags.dlcode); (* see selection.ml *) + `[{emit_reg r}, #:lo12:{emit_symbol_offset s ofs}]` + + (* Record live pointers at call points *) +@@ -323,7 +324,7 @@ let emit_literals() = + (* Emit code to load the address of a symbol *) + + let emit_load_symbol_addr dst s = +- if (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit s then begin ++ if not !Clflags.dlcode then begin + ` adrp {emit_reg dst}, {emit_symbol s}\n`; + ` add {emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n` + end else begin +@@ -609,6 +610,7 @@ let emit_instr i = + match addr with + | Iindexed _ -> i.arg.(0) + | Ibased(s, ofs) -> ++ assert (not !Clflags.dlcode); (* see selection.ml *) + ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; + reg_tmp1 in + begin match size with +@@ -636,6 +638,7 @@ let emit_instr i = + match addr with + | Iindexed _ -> i.arg.(1) + | Ibased(s, ofs) -> ++ assert (not !Clflags.dlcode); + ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; + reg_tmp1 in + begin match size with +@@ -924,7 +927,15 @@ let fundecl fundecl = + + let emit_item = function + | Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; +- | Cdefine_symbol s -> `{emit_symbol s}:\n` ++ | Cdefine_symbol s -> ++ if !Clflags.dlcode then begin ++ (* GOT relocations against non-global symbols don't seem to work ++ properly: GOT entries are not created for the symbols and the ++ relocations evaluate to random other GOT entries. For the moment ++ force all symbols to be global. *) ++ ` .globl {emit_symbol s}\n`; ++ end; ++ `{emit_symbol s}:\n` + | Cint8 n -> ` .byte {emit_int n}\n` + | Cint16 n -> ` .short {emit_int n}\n` + | Cint32 n -> ` .long {emit_nativeint n}\n` +diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml +index d8ea7f83b..b714d0032 100644 +--- a/asmcomp/arm64/selection.ml ++++ b/asmcomp/arm64/selection.ml +@@ -82,8 +82,8 @@ let inline_ops = + [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap"; + "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ] + +-let use_direct_addressing symb = +- (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit symb ++let use_direct_addressing _symb = ++ not !Clflags.dlcode + + (* Instruction selection *) + +-- +2.13.2 + diff --git a/SOURCES/0012-arg-Allow-flags-such-as-flag-arg-as-well-as-flag-arg.patch b/SOURCES/0012-arg-Allow-flags-such-as-flag-arg-as-well-as-flag-arg.patch deleted file mode 100644 index 207fa58..0000000 --- a/SOURCES/0012-arg-Allow-flags-such-as-flag-arg-as-well-as-flag-arg.patch +++ /dev/null @@ -1,84 +0,0 @@ -From af99e796d142efa9fc9717dcff3df55a4e82e6ca Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Tue, 1 Apr 2014 11:21:40 +0100 -Subject: [PATCH 12/19] arg: Allow flags such as --flag=arg as well as --flag - arg. - -Allow flags to be followed directly by their argument, separated by an '=' -sign. This is consistent with what GNU getopt_long and many other -command line parsing libraries allow. - -Fix for the following issue: -http://caml.inria.fr/mantis/view.php?id=5197 ---- - stdlib/arg.ml | 30 ++++++++++++++++++++++++------ - stdlib/arg.mli | 3 ++- - 2 files changed, 26 insertions(+), 7 deletions(-) - -diff --git a/stdlib/arg.ml b/stdlib/arg.ml -index c8b3d44..50d6e46 100644 ---- a/stdlib/arg.ml -+++ b/stdlib/arg.ml -@@ -55,6 +55,12 @@ let rec assoc3 x l = - | _ :: t -> assoc3 x t - ;; - -+let split s = -+ let i = String.index s '=' in -+ let len = String.length s in -+ String.sub s 0 i, String.sub s (i+1) (len-(i+1)) -+;; -+ - let make_symlist prefix sep suffix l = - match l with - | [] -> "" -@@ -130,14 +136,26 @@ let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg = - while !current < l do - let s = argv.(!current) in - if String.length s >= 1 && String.get s 0 = '-' then begin -- let action = -- try assoc3 s !speclist -- with Not_found -> stop (Unknown s) -+ let action, follow = -+ try assoc3 s !speclist, None -+ with Not_found -> -+ try -+ let keyword, arg = split s in -+ assoc3 keyword !speclist, Some arg -+ with Not_found -> stop (Unknown s) - in -- let no_arg () = () in -+ let no_arg () = -+ match follow with -+ | None -> () -+ | Some arg -> stop (Wrong (s, arg, "no argument")) in - let get_arg () = -- if !current + 1 < l then argv.(!current + 1) -- else stop (Missing s) -+ match follow with -+ | None -> -+ if !current + 1 < l then argv.(!current + 1) -+ else stop (Missing s) -+ | Some arg -> -+ decr current; -+ arg - in - begin try - let rec treat_action = function -diff --git a/stdlib/arg.mli b/stdlib/arg.mli -index 869d030..b8c6f11 100644 ---- a/stdlib/arg.mli -+++ b/stdlib/arg.mli -@@ -25,7 +25,8 @@ - [Unit], [Set] and [Clear] keywords take no argument. A [Rest] - keyword takes the remaining of the command line as arguments. - Every other keyword takes the following word on the command line -- as argument. -+ as argument. For compatibility with GNU getopt_long, [keyword=arg] -+ is also allowed. - Arguments not preceded by a keyword are called anonymous arguments. - - Examples ([cmd] is assumed to be the command name): --- -1.8.3.1 - diff --git a/SOURCES/0013-Add-support-for-ppc64le.patch b/SOURCES/0013-Add-support-for-ppc64le.patch deleted file mode 100644 index 0f4b690..0000000 --- a/SOURCES/0013-Add-support-for-ppc64le.patch +++ /dev/null @@ -1,1917 +0,0 @@ -From dbef48d3cb6424271e5d2296d16a3284db19cb25 Mon Sep 17 00:00:00 2001 -From: Michel Normand -Date: Tue, 18 Mar 2014 09:15:47 -0400 -Subject: [PATCH 13/19] Add support for ppc64le. - -Signed-off-by: Michel Normand ---- - asmcomp/power64le/arch.ml | 88 ++++ - asmcomp/power64le/emit.mlp | 981 ++++++++++++++++++++++++++++++++++++++++ - asmcomp/power64le/proc.ml | 240 ++++++++++ - asmcomp/power64le/reload.ml | 18 + - asmcomp/power64le/scheduling.ml | 65 +++ - asmcomp/power64le/selection.ml | 101 +++++ - asmrun/Makefile | 6 + - asmrun/power64-elf.S | 95 +++- - asmrun/power64le-elf.S | 1 + - asmrun/stack.h | 9 + - config/gnu/config.guess | 3 + - configure | 3 + - 12 files changed, 1609 insertions(+), 1 deletion(-) - create mode 100644 asmcomp/power64le/arch.ml - create mode 100644 asmcomp/power64le/emit.mlp - create mode 100644 asmcomp/power64le/proc.ml - create mode 100644 asmcomp/power64le/reload.ml - create mode 100644 asmcomp/power64le/scheduling.ml - create mode 100644 asmcomp/power64le/selection.ml - create mode 120000 asmrun/power64le-elf.S - -diff --git a/asmcomp/power64le/arch.ml b/asmcomp/power64le/arch.ml -new file mode 100644 -index 0000000..586534b ---- /dev/null -+++ b/asmcomp/power64le/arch.ml -@@ -0,0 +1,88 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: arch.ml 9547 2010-01-22 12:48:24Z doligez $ *) -+ -+(* Specific operations for the PowerPC processor *) -+ -+open Format -+ -+(* Machine-specific command-line options *) -+ -+let command_line_options = [] -+ -+(* Specific operations *) -+ -+type specific_operation = -+ Imultaddf (* multiply and add *) -+ | Imultsubf (* multiply and subtract *) -+ | Ialloc_far of int (* allocation in large functions *) -+ -+(* Addressing modes *) -+ -+type addressing_mode = -+ Ibased of string * int (* symbol + displ *) -+ | Iindexed of int (* reg + displ *) -+ | Iindexed2 (* reg + reg *) -+ -+(* Sizes, endianness *) -+ -+let big_endian = false -+ -+let size_addr = 8 -+let size_int = size_addr -+let size_float = 8 -+ -+let allow_unaligned_access = false -+ -+(* Behavior of division *) -+ -+let division_crashes_on_overflow = false -+ -+(* Operations on addressing modes *) -+ -+let identity_addressing = Iindexed 0 -+ -+let offset_addressing addr delta = -+ match addr with -+ Ibased(s, n) -> Ibased(s, n + delta) -+ | Iindexed n -> Iindexed(n + delta) -+ | Iindexed2 -> assert false -+ -+let num_args_addressing = function -+ Ibased(s, n) -> 0 -+ | Iindexed n -> 1 -+ | Iindexed2 -> 2 -+ -+(* Printing operations and addressing modes *) -+ -+let print_addressing printreg addr ppf arg = -+ match addr with -+ | Ibased(s, n) -> -+ let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in -+ fprintf ppf "\"%s\"%s" s idx -+ | Iindexed n -> -+ let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in -+ fprintf ppf "%a%s" printreg arg.(0) idx -+ | Iindexed2 -> -+ fprintf ppf "%a + %a" printreg arg.(0) printreg arg.(1) -+ -+let print_specific_operation printreg op ppf arg = -+ match op with -+ | Imultaddf -> -+ fprintf ppf "%a *f %a +f %a" -+ printreg arg.(0) printreg arg.(1) printreg arg.(2) -+ | Imultsubf -> -+ fprintf ppf "%a *f %a -f %a" -+ printreg arg.(0) printreg arg.(1) printreg arg.(2) -+ | Ialloc_far n -> -+ fprintf ppf "alloc_far %d" n -diff --git a/asmcomp/power64le/emit.mlp b/asmcomp/power64le/emit.mlp -new file mode 100644 -index 0000000..5736a18 ---- /dev/null -+++ b/asmcomp/power64le/emit.mlp -@@ -0,0 +1,981 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: emit.mlp 9547 2010-01-22 12:48:24Z doligez $ *) -+ -+(* Emission of PowerPC assembly code *) -+ -+module StringSet = Set.Make(struct type t = string let compare = compare end) -+ -+open Misc -+open Cmm -+open Arch -+open Proc -+open Reg -+open Mach -+open Linearize -+open Emitaux -+ -+(* Layout of the stack. The stack is kept 16-aligned. *) -+ -+let stack_size_lbl = ref 0 -+let stack_slot_lbl = ref 0 -+let stack_args_size = ref 0 -+let stack_traps_size = ref 0 -+ -+(* We have a stack frame of our own if we call other functions (including -+ use of exceptions, or if we need more than the red zone *) -+let has_stack_frame () = -+ if !contains_calls || (num_stack_slots.(0) + num_stack_slots.(1)) > (288-16)/8 then -+ true -+ else -+ false -+ -+let frame_size_sans_args () = -+ let size = 8 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 48 in -+ Misc.align size 16 -+ -+let slot_offset loc cls = -+ match loc with -+ Local n -> -+ if cls = 0 -+ then (!stack_slot_lbl, num_stack_slots.(1) * 8 + n * 8) -+ else (!stack_slot_lbl, n * 8) -+ | Incoming n -> ((if has_stack_frame() then !stack_size_lbl else 0), 48 + n) -+ | Outgoing n -> (0, n) -+ -+(* Output a symbol *) -+ -+let emit_symbol = -+ match Config.system with -+ | "elf" | "bsd" -> (fun s -> Emitaux.emit_symbol '.' s) -+ | "rhapsody" -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s) -+ | _ -> assert false -+ -+(* Output a label *) -+ -+let label_prefix = -+ match Config.system with -+ | "elf" | "bsd" -> ".L" -+ | "rhapsody" -> "L" -+ | _ -> assert false -+ -+let emit_label lbl = -+ emit_string label_prefix; emit_int lbl -+ -+(* Section switching *) -+ -+let toc_space = -+ match Config.system with -+ | "elf" | "bsd" -> " .section \".toc\",\"aw\"\n" -+ | "rhapsody" -> " .toc\n" -+ | _ -> assert false -+ -+let data_space = -+ match Config.system with -+ | "elf" | "bsd" -> " .section \".data\"\n" -+ | "rhapsody" -> " .data\n" -+ | _ -> assert false -+ -+let abiversion = -+ match Config.system with -+ | "elf" | "bsd" -> " .abiversion 2\n" -+ | _ -> assert false -+ -+let code_space = -+ match Config.system with -+ | "elf" | "bsd" -> " .section \".text\"\n" -+ | "rhapsody" -> " .text\n" -+ | _ -> assert false -+ -+let rodata_space = -+ match Config.system with -+ | "elf" | "bsd" -> " .section \".rodata\"\n" -+ | "rhapsody" -> " .const\n" -+ | _ -> assert false -+ -+(* Output a pseudo-register *) -+ -+let emit_reg r = -+ match r.loc with -+ Reg r -> emit_string (register_name r) -+ | _ -> fatal_error "Emit.emit_reg" -+ -+let use_full_regnames = -+ Config.system = "rhapsody" -+ -+let emit_gpr r = -+ if use_full_regnames then emit_char 'r'; -+ emit_int r -+ -+let emit_fpr r = -+ if use_full_regnames then emit_char 'f'; -+ emit_int r -+ -+let emit_ccr r = -+ if use_full_regnames then emit_string "cr"; -+ emit_int r -+ -+(* Output a stack reference *) -+ -+let emit_stack r = -+ match r.loc with -+ Stack s -> -+ let lbl, ofs = slot_offset s (register_class r) in -+ if lbl > 0 then -+ `{emit_label lbl}+`; -+ `{emit_int ofs}({emit_gpr 1})` -+ | _ -> fatal_error "Emit.emit_stack" -+ -+(* Split a 32-bit integer constants in two 16-bit halves *) -+ -+let low n = n land 0xFFFF -+let high n = n asr 16 -+ -+let nativelow n = Nativeint.to_int n land 0xFFFF -+let nativehigh n = Nativeint.to_int (Nativeint.shift_right n 16) -+ -+let is_immediate n = -+ n <= 32767 && n >= -32768 -+ -+let is_native_immediate n = -+ n <= 32767n && n >= -32768n -+ -+ -+type tocentry = -+ TocSymOfs of (string * int) -+ | TocLabel of int -+ | TocInt of nativeint -+ | TocFloat of string -+ -+(* List of all labels in tocref (reverse order) *) -+let tocref_entries = ref [] -+ -+(* Output a TOC reference *) -+ -+let emit_symbol_offset (s, d) = -+ emit_symbol s; -+ if d > 0 then `+`; -+ if d <> 0 then emit_int d -+ -+let emit_tocentry entry = -+ match entry with -+ TocSymOfs(s,d) -> emit_symbol_offset(s,d) -+ | TocInt i -> emit_nativeint i -+ | TocFloat f -> emit_string f -+ | TocLabel lbl -> emit_label lbl -+ -+ let rec tocref_label = function -+ ( [] , content ) -> -+ let lbl = new_label() in -+ tocref_entries := (lbl, content) :: !tocref_entries; -+ lbl -+ | ( (lbl, o_content) :: lst, content) -> -+ if content = o_content then -+ lbl -+ else -+ tocref_label (lst, content) -+ -+let emit_tocref entry = -+ let lbl = tocref_label (!tocref_entries,entry) in -+ emit_label lbl; emit_string "@toc(2) #"; emit_tocentry entry -+ -+ -+(* Output a load or store operation *) -+ -+let valid_offset instr ofs = -+ ofs land 3 = 0 || (instr <> "ld" && instr <> "std") -+ -+let emit_load_store instr addressing_mode addr n arg = -+ match addressing_mode with -+ Ibased(s, d) -> -+ let dd = (d + 0x8000) in (* We can only offset by -0x8000 .. +0x7fff *) -+ let a = (dd land -0x10000) in -+ let b = (dd land 0xffff) - 0x8000 in -+ ` ld {emit_gpr 11}, {emit_tocref (TocSymOfs (s,a))}\n`; -+ ` {emit_string instr} {emit_reg arg}, {emit_int b}({emit_gpr 11})\n` -+ | Iindexed ofs -> -+ if is_immediate ofs && valid_offset instr ofs then -+ ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n` -+ else begin -+ ` lis {emit_gpr 0}, {emit_int(high ofs)}\n`; -+ if low ofs <> 0 then -+ ` ori {emit_gpr 0}, {emit_gpr 0}, {emit_int(low ofs)}\n`; -+ ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_gpr 0}\n` -+ end -+ | Iindexed2 -> -+ ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n` -+ -+(* After a comparison, extract the result as 0 or 1 *) -+ -+let emit_set_comp cmp res = -+ ` mfcr {emit_gpr 0}\n`; -+ let bitnum = -+ match cmp with -+ Ceq | Cne -> 2 -+ | Cgt | Cle -> 1 -+ | Clt | Cge -> 0 in -+` rlwinm {emit_reg res}, {emit_gpr 0}, {emit_int(bitnum+1)}, 31, 31\n`; -+ begin match cmp with -+ Cne | Cle | Cge -> ` xori {emit_reg res}, {emit_reg res}, 1\n` -+ | _ -> () -+ end -+ -+(* Record live pointers at call points *) -+ -+type frame_descr = -+ { fd_lbl: int; (* Return address *) -+ fd_frame_size_lbl: int; (* Size of stack frame *) -+ fd_live_offset: (int * int) list } (* Offsets/regs of live addresses *) -+ -+let frame_descriptors = ref([] : frame_descr list) -+ -+let record_frame live = -+ let lbl = new_label() in -+ let live_offset = ref [] in -+ Reg.Set.iter -+ (function -+ {typ = Addr; loc = Reg r} -> -+ live_offset := (0, (r lsl 1) + 1) :: !live_offset -+ | {typ = Addr; loc = Stack s} as reg -> -+ live_offset := slot_offset s (register_class reg) :: !live_offset -+ | _ -> ()) -+ live; -+ frame_descriptors := -+ { fd_lbl = lbl; -+ fd_frame_size_lbl = !stack_size_lbl; (* frame_size *) -+ fd_live_offset = !live_offset } :: !frame_descriptors; -+ `{emit_label lbl}:\n` -+ -+let emit_frame fd = -+ ` .quad {emit_label fd.fd_lbl} + 4\n`; -+ ` .short {emit_label fd.fd_frame_size_lbl}\n`; -+ ` .short {emit_int (List.length fd.fd_live_offset)}\n`; -+ List.iter -+ (fun (lbl,n) -> -+ ` .short `; -+ if lbl > 0 then `{emit_label lbl}+`; -+ `{emit_int n}\n`) -+ fd.fd_live_offset; -+ ` .align 3\n` -+ -+(* Record external C functions to be called in a position-independent way -+ (for MacOSX) *) -+ -+let pic_externals = (Config.system = "rhapsody") -+ -+let external_functions = ref StringSet.empty -+ -+let emit_external s = -+ ` .non_lazy_symbol_pointer\n`; -+ `L{emit_symbol s}$non_lazy_ptr:\n`; -+ ` .indirect_symbol {emit_symbol s}\n`; -+ ` .quad 0\n` -+ -+(* Names for conditional branches after comparisons *) -+ -+let branch_for_comparison = function -+ Ceq -> "beq" | Cne -> "bne" -+ | Cle -> "ble" | Cgt -> "bgt" -+ | Cge -> "bge" | Clt -> "blt" -+ -+let name_for_int_comparison = function -+ Isigned cmp -> ("cmpd", branch_for_comparison cmp) -+ | Iunsigned cmp -> ("cmpld", branch_for_comparison cmp) -+ -+(* Names for various instructions *) -+ -+let name_for_intop = function -+ Iadd -> "add" -+ | Imul -> "mulld" -+ | Idiv -> "divd" -+ | Iand -> "and" -+ | Ior -> "or" -+ | Ixor -> "xor" -+ | Ilsl -> "sld" -+ | Ilsr -> "srd" -+ | Iasr -> "srad" -+ | _ -> Misc.fatal_error "Emit.Intop" -+ -+let name_for_intop_imm = function -+ Iadd -> "addi" -+ | Imul -> "mulli" -+ | Iand -> "andi." -+ | Ior -> "ori" -+ | Ixor -> "xori" -+ | Ilsl -> "sldi" -+ | Ilsr -> "srdi" -+ | Iasr -> "sradi" -+ | _ -> Misc.fatal_error "Emit.Intop_imm" -+ -+let name_for_floatop1 = function -+ Inegf -> "fneg" -+ | Iabsf -> "fabs" -+ | _ -> Misc.fatal_error "Emit.Iopf1" -+ -+let name_for_floatop2 = function -+ Iaddf -> "fadd" -+ | Isubf -> "fsub" -+ | Imulf -> "fmul" -+ | Idivf -> "fdiv" -+ | _ -> Misc.fatal_error "Emit.Iopf2" -+ -+let name_for_specific = function -+ Imultaddf -> "fmadd" -+ | Imultsubf -> "fmsub" -+ | _ -> Misc.fatal_error "Emit.Ispecific" -+ -+(* Name of current function *) -+let function_name = ref "" -+(* Entry point for tail recursive calls *) -+let tailrec_entry_point = ref 0 -+(* Names of functions defined in the current file *) -+let defined_functions = ref StringSet.empty -+(* Label of glue code for calling the GC *) -+let call_gc_label = ref 0 -+(* Label of jump table *) -+let lbl_jumptbl = ref 0 -+(* List of all labels in jumptable (reverse order) *) -+let jumptbl_entries = ref [] -+(* Number of jumptable entries *) -+let num_jumptbl_entries = ref 0 -+ -+(* Fixup conditional branches that exceed hardware allowed range *) -+ -+let load_store_size = function -+ Ibased(s, d) -> 2 -+ | Iindexed ofs -> if is_immediate ofs then 1 else 3 -+ | Iindexed2 -> 1 -+ -+let instr_size = function -+ Lend -> 0 -+ | Lop(Imove | Ispill | Ireload) -> 1 -+ | Lop(Iconst_int n) -> if is_native_immediate n then 1 else 2 -+ | Lop(Iconst_float s) -> 2 -+ | Lop(Iconst_symbol s) -> 2 -+ | Lop(Icall_ind) -> 4 -+ | Lop(Icall_imm s) -> 5 -+ | Lop(Itailcall_ind) -> if !contains_calls then 5 else if has_stack_frame() then 3 else 2 -+ | Lop(Itailcall_imm s) -> if s = !function_name then 1 else -+ if !contains_calls then 6 else -+ if has_stack_frame() then 4 else 3 -+ | Lop(Iextcall(s, true)) -> 6 -+ | Lop(Iextcall(s, false)) -> 5 -+ | Lop(Istackoffset n) -> 0 -+ | Lop(Iload(chunk, addr)) -> -+ if chunk = Byte_signed -+ then load_store_size addr + 1 -+ else load_store_size addr -+ | Lop(Istore(chunk, addr)) -> load_store_size addr -+ | Lop(Ialloc n) -> 4 -+ | Lop(Ispecific(Ialloc_far n)) -> 5 -+ | Lop(Iintop Imod) -> 3 -+ | Lop(Iintop(Icomp cmp)) -> 4 -+ | Lop(Iintop op) -> 1 -+ | Lop(Iintop_imm(Idiv, n)) -> 2 -+ | Lop(Iintop_imm(Imod, n)) -> 4 -+ | Lop(Iintop_imm(Icomp cmp, n)) -> 4 -+ | Lop(Iintop_imm(op, n)) -> 1 -+ | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 -+ | Lop(Ifloatofint) -> 3 -+ | Lop(Iintoffloat) -> 3 -+ | Lop(Ispecific sop) -> 1 -+ | Lreloadretaddr -> 2 -+ | Lreturn -> if has_stack_frame() then 2 else 1 -+ | Llabel lbl -> 0 -+ | Lbranch lbl -> 1 -+ | Lcondbranch(tst, lbl) -> 2 -+ | Lcondbranch3(lbl0, lbl1, lbl2) -> -+ 1 + (if lbl0 = None then 0 else 1) -+ + (if lbl1 = None then 0 else 1) -+ + (if lbl2 = None then 0 else 1) -+ | Lswitch jumptbl -> 7 -+ | Lsetuptrap lbl -> 1 -+ | Lpushtrap -> 7 -+ | Lpoptrap -> 1 -+ | Lraise -> 6 -+ -+let label_map code = -+ let map = Hashtbl.create 37 in -+ let rec fill_map pc instr = -+ match instr.desc with -+ Lend -> (pc, map) -+ | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next -+ | op -> fill_map (pc + instr_size op) instr.next -+ in fill_map 0 code -+ -+let max_branch_offset = 8180 -+(* 14-bit signed offset in words. Remember to cut some slack -+ for multi-word instructions where the branch can be anywhere in -+ the middle. 12 words of slack is plenty. *) -+ -+let branch_overflows map pc_branch lbl_dest = -+ let pc_dest = Hashtbl.find map lbl_dest in -+ let delta = pc_dest - (pc_branch + 1) in -+ delta <= -max_branch_offset || delta >= max_branch_offset -+ -+let opt_branch_overflows map pc_branch opt_lbl_dest = -+ match opt_lbl_dest with -+ None -> false -+ | Some lbl_dest -> branch_overflows map pc_branch lbl_dest -+ -+let fixup_branches codesize map code = -+ let expand_optbranch lbl n arg next = -+ match lbl with -+ None -> next -+ | Some l -> -+ instr_cons (Lcondbranch(Iinttest_imm(Isigned Ceq, n), l)) -+ arg [||] next in -+ let rec fixup did_fix pc instr = -+ match instr.desc with -+ Lend -> did_fix -+ | Lcondbranch(test, lbl) when branch_overflows map pc lbl -> -+ let lbl2 = new_label() in -+ let cont = -+ instr_cons (Lbranch lbl) [||] [||] -+ (instr_cons (Llabel lbl2) [||] [||] instr.next) in -+ instr.desc <- Lcondbranch(invert_test test, lbl2); -+ instr.next <- cont; -+ fixup true (pc + 2) instr.next -+ | Lcondbranch3(lbl0, lbl1, lbl2) -+ when opt_branch_overflows map pc lbl0 -+ || opt_branch_overflows map pc lbl1 -+ || opt_branch_overflows map pc lbl2 -> -+ let cont = -+ expand_optbranch lbl0 0 instr.arg -+ (expand_optbranch lbl1 1 instr.arg -+ (expand_optbranch lbl2 2 instr.arg instr.next)) in -+ instr.desc <- cont.desc; -+ instr.next <- cont.next; -+ fixup true pc instr -+ | Lop(Ialloc n) when codesize - pc >= max_branch_offset -> -+ instr.desc <- Lop(Ispecific(Ialloc_far n)); -+ fixup true (pc + 4) instr.next -+ | op -> -+ fixup did_fix (pc + instr_size op) instr.next -+ in fixup false 0 code -+ -+(* Iterate branch expansion till all conditional branches are OK *) -+ -+let rec branch_normalization code = -+ let (codesize, map) = label_map code in -+ if codesize >= max_branch_offset && fixup_branches codesize map code -+ then branch_normalization code -+ else () -+ -+ -+(* Output the assembly code for an instruction *) -+ -+let rec emit_instr i dslot = -+ match i.desc with -+ Lend -> () -+ | Lop(Imove | Ispill | Ireload) -> -+ let src = i.arg.(0) and dst = i.res.(0) in -+ if src.loc <> dst.loc then begin -+ match (src, dst) with -+ {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> -+ ` mr {emit_reg dst}, {emit_reg src}\n` -+ | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> -+ ` fmr {emit_reg dst}, {emit_reg src}\n` -+ | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> -+ ` std {emit_reg src}, {emit_stack dst}\n` -+ | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> -+ ` stfd {emit_reg src}, {emit_stack dst}\n` -+ | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> -+ ` ld {emit_reg dst}, {emit_stack src}\n` -+ | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> -+ ` lfd {emit_reg dst}, {emit_stack src}\n` -+ | (_, _) -> -+ fatal_error "Emit: Imove" -+ end -+ | Lop(Iconst_int n) -> -+ if is_native_immediate n then -+ ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` -+ else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin -+ ` lis {emit_reg i.res.(0)}, {emit_int(nativehigh n)}\n`; -+ if nativelow n <> 0 then -+ ` ori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int(nativelow n)}\n` -+ end else begin -+ ` ld {emit_reg i.res.(0)}, {emit_tocref (TocInt n)}\n` -+ end -+ | Lop(Iconst_float s) -> -+ ` lfd {emit_reg i.res.(0)}, {emit_tocref (TocFloat s)}\n` -+ | Lop(Iconst_symbol s) -> -+ ` ld {emit_reg i.res.(0)}, {emit_tocref (TocSymOfs (s,0))}\n` -+ | Lop(Icall_ind) -> -+ ` std {emit_gpr 2},24({emit_gpr 1})\n`; -+ ` mtctr {emit_reg i.arg.(0)}\n`; -+ record_frame i.live; -+ ` bctrl\n`; -+ ` ld {emit_gpr 2},24({emit_gpr 1})\n` -+ | Lop(Icall_imm s) -> -+ ` ld {emit_gpr 12}, {emit_tocref (TocSymOfs (s,0))}\n`; -+ ` std {emit_gpr 2},24({emit_gpr 1})\n`; -+ ` mtctr {emit_gpr 12}\n`; -+ record_frame i.live; -+ ` bctrl\n`; -+ ` ld {emit_gpr 2},24({emit_gpr 1})\n` -+ | Lop(Itailcall_ind) -> -+ ` mtctr {emit_reg i.arg.(0)}\n`; -+ if has_stack_frame() then -+ ` ld {emit_gpr 1}, 0({emit_gpr 1})\n`; -+ if !contains_calls then begin -+ ` ld {emit_gpr 12}, 16({emit_gpr 1})\n`; -+ ` mtlr {emit_gpr 12}\n` -+ end; -+ ` bctr\n` -+ | Lop(Itailcall_imm s) -> -+ if s = !function_name then -+ ` b {emit_label !tailrec_entry_point}\n` -+ else begin -+ if has_stack_frame() then -+ ` ld {emit_gpr 1}, 0({emit_gpr 1})\n`; -+ if !contains_calls then begin -+ ` ld {emit_gpr 12}, 16({emit_gpr 1})\n`; -+ ` mtlr {emit_gpr 12}\n` -+ end; -+ ` ld {emit_gpr 12}, {emit_tocref (TocSymOfs (s,0))}\n`; -+ ` mtctr {emit_gpr 12}\n`; -+ ` bctr\n` -+ end -+ | Lop(Iextcall(s, alloc)) -> -+ if alloc then begin -+ ` ld {emit_gpr 11}, {emit_tocref (TocSymOfs (s,0))}\n`; -+ ` ld {emit_gpr 12}, {emit_tocref (TocSymOfs ("caml_c_call",0))}\n`; -+ end else -+ ` ld {emit_gpr 12}, {emit_tocref (TocSymOfs (s,0))}\n`; -+ ` std {emit_gpr 2}, 24({emit_gpr 1})\n`; -+ ` mtctr {emit_gpr 12}\n`; -+ if alloc then record_frame i.live; -+ ` bctrl\n`; -+ ` ld {emit_gpr 2}, 24({emit_gpr 1})\n` -+ | Lop(Istackoffset n) -> -+ if n > !stack_args_size then -+ stack_args_size := n -+ | Lop(Iload(chunk, addr)) -> -+ let loadinstr = -+ match chunk with -+ Byte_unsigned -> "lbz" -+ | Byte_signed -> "lbz" -+ | Sixteen_unsigned -> "lhz" -+ | Sixteen_signed -> "lha" -+ | Thirtytwo_unsigned -> "lwz" -+ | Thirtytwo_signed -> "lwa" -+ | Word -> "ld" -+ | Single -> "lfs" -+ | Double | Double_u -> "lfd" in -+ emit_load_store loadinstr addr i.arg 0 i.res.(0); -+ if chunk = Byte_signed then -+ ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` -+ | Lop(Istore(chunk, addr)) -> -+ let storeinstr = -+ match chunk with -+ Byte_unsigned | Byte_signed -> "stb" -+ | Sixteen_unsigned | Sixteen_signed -> "sth" -+ | Thirtytwo_unsigned | Thirtytwo_signed -> "stw" -+ | Word -> "std" -+ | Single -> "stfs" -+ | Double | Double_u -> "stfd" in -+ emit_load_store storeinstr addr i.arg 1 i.arg.(0) -+ | Lop(Ialloc n) -> -+ if !call_gc_label = 0 then call_gc_label := new_label(); -+ ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; -+ ` cmpld {emit_gpr 31}, {emit_gpr 30}\n`; -+ ` addi {emit_reg i.res.(0)}, {emit_gpr 31}, 8\n`; -+ record_frame i.live; -+ ` bltl {emit_label !call_gc_label}\n` (* Must be 4 insns to restart *) -+ | Lop(Ispecific(Ialloc_far n)) -> -+ if !call_gc_label = 0 then call_gc_label := new_label(); -+ let lbl = new_label() in -+ ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; -+ ` cmpld {emit_gpr 31}, {emit_gpr 30}\n`; -+ ` bge {emit_label lbl}\n`; -+ record_frame i.live; -+ ` bl {emit_label !call_gc_label}\n`; (* Must be 4 insns to restart *) -+ `{emit_label lbl}: addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n` -+ | Lop(Iintop Isub) -> (* subfc has swapped arguments *) -+ ` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` -+ | Lop(Iintop Imod) -> -+ ` divd {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ ` mulld {emit_gpr 0}, {emit_gpr 0}, {emit_reg i.arg.(1)}\n`; -+ ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` -+ | Lop(Iintop(Icomp cmp)) -> -+ begin match cmp with -+ Isigned c -> -+ ` cmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ emit_set_comp c i.res.(0) -+ | Iunsigned c -> -+ ` cmpld {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ emit_set_comp c i.res.(0) -+ end -+ | Lop(Iintop Icheckbound) -> -+ ` tdlle {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` -+ | Lop(Iintop op) -> -+ let instr = name_for_intop op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` -+ | Lop(Iintop_imm(Isub, n)) -> -+ ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n` -+ | Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *) -+ let l = Misc.log2 n in -+ ` sradi {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` -+ | Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *) -+ let l = Misc.log2 n in -+ ` sradi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; -+ ` addze {emit_gpr 0}, {emit_gpr 0}\n`; -+ ` sldi {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` -+ | Lop(Iintop_imm(Icomp cmp, n)) -> -+ begin match cmp with -+ Isigned c -> -+ ` cmpdi {emit_reg i.arg.(0)}, {emit_int n}\n`; -+ emit_set_comp c i.res.(0) -+ | Iunsigned c -> -+ ` cmpldi {emit_reg i.arg.(0)}, {emit_int n}\n`; -+ emit_set_comp c i.res.(0) -+ end -+ | Lop(Iintop_imm(Icheckbound, n)) -> -+ ` tdllei {emit_reg i.arg.(0)}, {emit_int n}\n` -+ | Lop(Iintop_imm(op, n)) -> -+ let instr = name_for_intop_imm op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n` -+ | Lop(Inegf | Iabsf as op) -> -+ let instr = name_for_floatop1 op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` -+ | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> -+ let instr = name_for_floatop2 op in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` -+ | Lop(Ifloatofint) -> -+ let ofs = if has_stack_frame() then 16 else 8 * (2 + num_stack_slots.(0) + num_stack_slots.(1)) in -+ ` std {emit_reg i.arg.(0)}, -{emit_int ofs}({emit_gpr 1})\n`; -+ ` lfd {emit_reg i.res.(0)}, -{emit_int ofs}({emit_gpr 1})\n`; -+ ` fcfid {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` -+ | Lop(Iintoffloat) -> -+ let ofs = if has_stack_frame() then 16 else 8 * (2 + num_stack_slots.(0) + num_stack_slots.(1)) in -+ ` fctidz {emit_fpr 0}, {emit_reg i.arg.(0)}\n`; -+ ` stfd {emit_fpr 0}, -{emit_int ofs}({emit_gpr 1})\n`; -+ ` ld {emit_reg i.res.(0)}, -{emit_int ofs}({emit_gpr 1})\n` -+ | Lop(Ispecific sop) -> -+ let instr = name_for_specific sop in -+ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` -+ | Lreloadretaddr -> -+ if has_stack_frame() then begin -+ ` ld {emit_gpr 12}, {emit_label !stack_size_lbl}+16({emit_gpr 1})\n`; -+ ` mtlr {emit_gpr 12}\n` -+ end -+ | Lreturn -> -+ if has_stack_frame() then -+ ` ld {emit_gpr 1}, 0({emit_gpr 1})\n`; -+ ` blr\n` -+ | Llabel lbl -> -+ `{emit_label lbl}:\n` -+ | Lbranch lbl -> -+ ` b {emit_label lbl}\n` -+ | Lcondbranch(tst, lbl) -> -+ begin match tst with -+ Itruetest -> -+ ` cmpdi {emit_reg i.arg.(0)}, 0\n`; -+ emit_delay dslot; -+ ` bne {emit_label lbl}\n` -+ | Ifalsetest -> -+ ` cmpdi {emit_reg i.arg.(0)}, 0\n`; -+ emit_delay dslot; -+ ` beq {emit_label lbl}\n` -+ | Iinttest cmp -> -+ let (comp, branch) = name_for_int_comparison cmp in -+ ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ emit_delay dslot; -+ ` {emit_string branch} {emit_label lbl}\n` -+ | Iinttest_imm(cmp, n) -> -+ let (comp, branch) = name_for_int_comparison cmp in -+ ` {emit_string comp}i {emit_reg i.arg.(0)}, {emit_int n}\n`; -+ emit_delay dslot; -+ ` {emit_string branch} {emit_label lbl}\n` -+ | Ifloattest(cmp, neg) -> -+ ` fcmpu {emit_ccr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; -+ (* bit 0 = lt, bit 1 = gt, bit 2 = eq *) -+ let (bitnum, negtst) = -+ match cmp with -+ Ceq -> (2, neg) -+ | Cne -> (2, not neg) -+ | Cle -> ` cror 3, 0, 2\n`; (* lt or eq *) -+ (3, neg) -+ | Cgt -> (1, neg) -+ | Cge -> ` cror 3, 1, 2\n`; (* gt or eq *) -+ (3, neg) -+ | Clt -> (0, neg) in -+ emit_delay dslot; -+ if negtst -+ then ` bf {emit_int bitnum}, {emit_label lbl}\n` -+ else ` bt {emit_int bitnum}, {emit_label lbl}\n` -+ | Ioddtest -> -+ ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; -+ emit_delay dslot; -+ ` bne {emit_label lbl}\n` -+ | Ieventest -> -+ ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; -+ emit_delay dslot; -+ ` beq {emit_label lbl}\n` -+ end -+ | Lcondbranch3(lbl0, lbl1, lbl2) -> -+ ` cmpdi {emit_reg i.arg.(0)}, 1\n`; -+ emit_delay dslot; -+ begin match lbl0 with -+ None -> () -+ | Some lbl -> ` blt {emit_label lbl}\n` -+ end; -+ begin match lbl1 with -+ None -> () -+ | Some lbl -> ` beq {emit_label lbl}\n` -+ end; -+ begin match lbl2 with -+ None -> () -+ | Some lbl -> ` bgt {emit_label lbl}\n` -+ end -+ | Lswitch jumptbl -> -+ if !lbl_jumptbl = 0 then lbl_jumptbl := new_label(); -+ ` ld {emit_gpr 11}, {emit_tocref (TocLabel !lbl_jumptbl)}\n`; -+ ` addi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int !num_jumptbl_entries}\n`; -+ ` sldi {emit_gpr 0}, {emit_gpr 0}, 2\n`; -+ ` lwax {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; -+ ` add {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; -+ ` mtctr {emit_gpr 0}\n`; -+ ` bctr\n`; -+ for i = 0 to Array.length jumptbl - 1 do -+ jumptbl_entries := jumptbl.(i) :: !jumptbl_entries; -+ incr num_jumptbl_entries -+ done -+ | Lsetuptrap lbl -> -+ ` bl {emit_label lbl}\n`; -+ | Lpushtrap -> -+ stack_traps_size := !stack_traps_size + 32; -+ ` addi {emit_gpr 11}, {emit_gpr 1}, {emit_label !stack_size_lbl}-{emit_int !stack_traps_size}\n`; -+ ` mflr {emit_gpr 0}\n`; -+ ` std {emit_gpr 29}, 0({emit_gpr 11})\n`; -+ ` std {emit_gpr 0}, 8({emit_gpr 11})\n`; -+ ` std {emit_gpr 1}, 16({emit_gpr 11})\n`; -+ ` std {emit_gpr 2}, 24({emit_gpr 11})\n`; -+ ` mr {emit_gpr 29}, {emit_gpr 11}\n` -+ | Lpoptrap -> -+ ` ld {emit_gpr 29}, 0({emit_gpr 29})\n` -+ | Lraise -> -+ ` ld {emit_gpr 0}, 8({emit_gpr 29})\n`; -+ ` ld {emit_gpr 1}, 16({emit_gpr 29})\n`; -+ ` ld {emit_gpr 2}, 24({emit_gpr 29})\n`; -+ ` mtlr {emit_gpr 0}\n`; -+ ` ld {emit_gpr 29}, 0({emit_gpr 29})\n`; -+ ` blr\n` -+ -+and emit_delay = function -+ None -> () -+ | Some i -> emit_instr i None -+ -+(* Checks if a pseudo-instruction expands to instructions -+ that do not branch and do not affect CR0 nor R12. *) -+ -+let is_simple_instr i = -+ match i.desc with -+ Lop op -> -+ begin match op with -+ Icall_imm _ | Icall_ind | Itailcall_imm _ | Itailcall_ind | -+ Iextcall(_, _) -> false -+ | Ialloc(_) -> false -+ | Iintop(Icomp _) -> false -+ | Iintop_imm(Iand, _) -> false -+ | Iintop_imm(Icomp _, _) -> false -+ | _ -> true -+ end -+ | Lreloadretaddr -> true -+ | _ -> false -+ -+let no_interference res arg = -+ try -+ for i = 0 to Array.length arg - 1 do -+ for j = 0 to Array.length res - 1 do -+ if arg.(i).loc = res.(j).loc then raise Exit -+ done -+ done; -+ true -+ with Exit -> -+ false -+ -+(* Emit a sequence of instructions, trying to fill delay slots for branches *) -+ -+let rec emit_all i = -+ match i with -+ {desc = Lend} -> () -+ | {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}} -+ when is_simple_instr i && no_interference i.res i.next.arg -> -+ emit_instr i.next (Some i); -+ emit_all i.next.next -+ | _ -> -+ emit_instr i None; -+ emit_all i.next -+ -+(* Emission of a function declaration *) -+ -+let fundecl fundecl = -+ function_name := fundecl.fun_name; -+ defined_functions := StringSet.add fundecl.fun_name !defined_functions; -+ tailrec_entry_point := new_label(); -+ if has_stack_frame() then -+ stack_size_lbl := new_label(); -+ stack_slot_lbl := new_label(); -+ stack_args_size := 0; -+ stack_traps_size := 0; -+ call_gc_label := 0; -+ ` .globl {emit_symbol fundecl.fun_name}\n`; -+ begin match Config.system with -+ | "elf" | "bsd" -> -+ ` .type {emit_symbol fundecl.fun_name}, @function\n`; -+ emit_string code_space; -+ `{emit_symbol fundecl.fun_name}:\n`; -+ | _ -> -+ ` .align 2\n`; -+ emit_string code_space; -+ `{emit_symbol fundecl.fun_name}:\n` -+ end; -+ (* r2 to be setup to current toc *) -+ `0: addis {emit_gpr 2}, {emit_gpr 12},.TOC.-0b@ha\n`; -+ ` addi {emit_gpr 2}, {emit_gpr 2},.TOC.-0b@l\n`; -+ ` .localentry {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`; -+ if !contains_calls then begin -+ ` mflr {emit_gpr 0}\n`; -+ ` std {emit_gpr 0}, 16({emit_gpr 1})\n` -+ end; -+ if has_stack_frame() then -+ ` stdu {emit_gpr 1}, -{emit_label !stack_size_lbl}({emit_gpr 1})\n`; -+ `{emit_label !tailrec_entry_point}:\n`; -+ branch_normalization fundecl.fun_body; -+ emit_all fundecl.fun_body; -+ ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`; -+ if has_stack_frame() then begin -+ ` .set {emit_label !stack_size_lbl},{emit_int (frame_size_sans_args() + !stack_args_size + !stack_traps_size)} # stack size including traps\n`; -+ ` .set {emit_label !stack_slot_lbl},{emit_int (48 + !stack_args_size)} # stack slot offset\n` -+ end else (* leave 8 bytes for float <-> conversions *) -+ ` .set {emit_label !stack_slot_lbl},{emit_int (40-frame_size_sans_args())} # stack slot offset (negative)\n`; -+ -+ (* Emit the glue code to call the GC *) -+ if !call_gc_label > 0 then begin -+ `{emit_label !call_gc_label}:\n`; -+ ` ld {emit_gpr 12}, {emit_tocref (TocSymOfs ("caml_call_gc",0))}\n`; -+ ` mtctr {emit_gpr 12}\n`; -+ ` bctr\n`; -+ end -+ -+(* Emission of data *) -+ -+let declare_global_data s = -+ ` .globl {emit_symbol s}\n`; -+ if Config.system = "elf" || Config.system = "bsd" then -+ ` .type {emit_symbol s}, @object\n` -+ -+let emit_item = function -+ Cglobal_symbol s -> -+ declare_global_data s -+ | Cdefine_symbol s -> -+ `{emit_symbol s}:\n`; -+ | Cdefine_label lbl -> -+ `{emit_label (lbl + 100000)}:\n` -+ | Cint8 n -> -+ ` .byte {emit_int n}\n` -+ | Cint16 n -> -+ ` .short {emit_int n}\n` -+ | Cint32 n -> -+ ` .long {emit_nativeint n}\n` -+ | Cint n -> -+ ` .quad {emit_nativeint n}\n` -+ | Csingle f -> -+ ` .float 0d{emit_string f}\n` -+ | Cdouble f -> -+ ` .double 0d{emit_string f}\n` -+ | Csymbol_address s -> -+ ` .quad {emit_symbol s}\n` -+ | Clabel_address lbl -> -+ ` .quad {emit_label (lbl + 100000)}\n` -+ | Cstring s -> -+ emit_bytes_directive " .byte " s -+ | Cskip n -> -+ if n > 0 then ` .space {emit_int n}\n` -+ | Calign n -> -+ ` .align {emit_int (Misc.log2 n)}\n` -+ -+let data l = -+ emit_string data_space; -+ List.iter emit_item l -+ -+(* Beginning / end of an assembly file *) -+ -+let begin_assembly() = -+ defined_functions := StringSet.empty; -+ external_functions := StringSet.empty; -+ tocref_entries := []; -+ num_jumptbl_entries := 0; -+ jumptbl_entries := []; -+ lbl_jumptbl := 0; -+ (* Emit the beginning of the segments *) -+ let lbl_begin = Compilenv.make_symbol (Some "data_begin") in -+ emit_string data_space; -+ declare_global_data lbl_begin; -+ emit_string abiversion; -+ `{emit_symbol lbl_begin}:\n`; -+ let lbl_begin = Compilenv.make_symbol (Some "code_begin") in -+ emit_string code_space; -+ declare_global_data lbl_begin; -+ `{emit_symbol lbl_begin}:\n` -+ -+let end_assembly() = -+ (* Emit the jump table *) -+ if !num_jumptbl_entries > 0 then begin -+ emit_string code_space; -+ `{emit_label !lbl_jumptbl}:\n`; -+ List.iter -+ (fun lbl -> ` .long {emit_label lbl} - {emit_label !lbl_jumptbl}\n`) -+ (List.rev !jumptbl_entries); -+ jumptbl_entries := [] -+ end; -+ if !tocref_entries <> [] then begin -+ emit_string toc_space; -+ List.iter -+ (fun (lbl, entry) -> -+ `{emit_label lbl}:\n`; -+ match entry with -+ TocFloat f -> -+ ` .double {emit_tocentry entry}\n` -+ | _ -> -+ ` .tc {emit_label lbl}[TC],{emit_tocentry entry}\n` -+ ) -+ !tocref_entries; -+ tocref_entries := [] -+ end; -+ if pic_externals then -+ (* Emit the pointers to external functions *) -+ StringSet.iter emit_external !external_functions; -+ (* Emit the end of the segments *) -+ emit_string code_space; -+ let lbl_end = Compilenv.make_symbol (Some "code_end") in -+ declare_global_data lbl_end; -+ `{emit_symbol lbl_end}:\n`; -+ ` .long 0\n`; -+ emit_string data_space; -+ let lbl_end = Compilenv.make_symbol (Some "data_end") in -+ declare_global_data lbl_end; -+ `{emit_symbol lbl_end}:\n`; -+ ` .quad 0\n`; -+ (* Emit the frame descriptors *) -+ emit_string rodata_space; -+ let lbl = Compilenv.make_symbol (Some "frametable") in -+ declare_global_data lbl; -+ `{emit_symbol lbl}:\n`; -+ ` .quad {emit_int (List.length !frame_descriptors)}\n`; -+ List.iter emit_frame !frame_descriptors; -+ frame_descriptors := [] -diff --git a/asmcomp/power64le/proc.ml b/asmcomp/power64le/proc.ml -new file mode 100644 -index 0000000..9b98577 ---- /dev/null -+++ b/asmcomp/power64le/proc.ml -@@ -0,0 +1,240 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: proc.ml 9547 2010-01-22 12:48:24Z doligez $ *) -+ -+(* Description of the Power PC *) -+ -+open Misc -+open Cmm -+open Reg -+open Arch -+open Mach -+ -+(* Instruction selection *) -+ -+let word_addressed = false -+ -+(* Registers available for register allocation *) -+ -+(* Integer register map: -+ 0 temporary, null register for some operations -+ 1 stack pointer -+ 2 pointer to table of contents -+ 3 - 10 function arguments and results -+ 11 - 12 temporaries -+ 13 pointer to small data area -+ 14 - 28 general purpose, preserved by C -+ 29 trap pointer -+ 30 allocation limit -+ 31 allocation pointer -+ Floating-point register map: -+ 0 temporary -+ 1 - 13 function arguments and results -+ 14 - 31 general purpose, preserved by C -+*) -+ -+let int_reg_name = -+ if Config.system = "rhapsody" then -+ [| "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "r10"; -+ "r14"; "r15"; "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; -+ "r22"; "r23"; "r24"; "r25"; "r26"; "r27"; "r28" |] -+ else -+ [| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; -+ "14"; "15"; "16"; "17"; "18"; "19"; "20"; "21"; -+ "22"; "23"; "24"; "25"; "26"; "27"; "28" |] -+ -+let float_reg_name = -+ if Config.system = "rhapsody" then -+ [| "f1"; "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; "f8"; -+ "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; "f16"; -+ "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23"; "f24"; -+ "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31" |] -+ else -+ [| "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"; "31" |] -+ -+let num_register_classes = 2 -+ -+let register_class r = -+ match r.typ with -+ Int -> 0 -+ | Addr -> 0 -+ | Float -> 1 -+ -+let num_available_registers = [| 23; 31 |] -+ -+let first_available_register = [| 0; 100 |] -+ -+let register_name r = -+ if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) -+ -+let rotate_registers = true -+ -+(* Representation of hard registers by pseudo-registers *) -+ -+let hard_int_reg = -+ let v = Array.create 23 Reg.dummy in -+ for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v -+ -+let hard_float_reg = -+ let v = Array.create 31 Reg.dummy in -+ for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v -+ -+let all_phys_regs = -+ Array.append hard_int_reg hard_float_reg -+ -+let phys_reg n = -+ if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) -+ -+let stack_slot slot ty = -+ Reg.at_location ty (Stack slot) -+ -+(* Calling conventions *) -+ -+let calling_conventions -+ first_int last_int first_float last_float make_stack stack_ofs arg = -+ let loc = Array.create (Array.length arg) Reg.dummy in -+ let int = ref first_int in -+ let float = ref first_float in -+ let ofs = ref stack_ofs in -+ for i = 0 to Array.length arg - 1 do -+ match arg.(i).typ with -+ Int | Addr as ty -> -+ if !int <= last_int then begin -+ loc.(i) <- phys_reg !int; -+ incr int -+ end else begin -+ loc.(i) <- stack_slot (make_stack !ofs) ty; -+ end; -+ ofs := !ofs + size_int -+ | Float -> -+ if !float <= last_float then begin -+ loc.(i) <- phys_reg !float; -+ incr float -+ end else begin -+ loc.(i) <- stack_slot (make_stack !ofs) Float; -+ end; -+ ofs := !ofs + size_float -+ done; -+ (loc, Misc.align !ofs 16) -+ (* Keep stack 16-aligned. *) -+ -+let incoming ofs = Incoming ofs -+let outgoing ofs = Outgoing ofs -+let not_supported ofs = fatal_error "Proc.loc_results: cannot call" -+ -+let loc_arguments arg = -+ calling_conventions 0 7 100 112 outgoing 48 arg -+let loc_parameters arg = -+ let (loc, ofs) = calling_conventions 0 7 100 112 incoming 0 arg in loc -+let loc_results res = -+ let (loc, ofs) = calling_conventions 0 7 100 112 not_supported 0 res in loc -+ -+(* C calling conventions under PowerOpen: -+ use GPR 3-10 and FPR 1-13 just like ML calling -+ conventions, but always reserve stack space for all arguments. -+ Also, using a float register automatically reserves two int registers -+ (in 32-bit mode) or one int register (in 64-bit mode). -+ (If we were to call a non-prototyped C function, each float argument -+ would have to go both in a float reg and in the matching pair -+ of integer regs.) -+ -+ C calling conventions under SVR4: -+ use GPR 3-10 and FPR 1-8 just like ML calling conventions. -+ Using a float register does not affect the int registers. -+ Always reserve 8 bytes at bottom of stack, plus whatever is needed -+ to hold the overflow arguments. *) -+ -+let poweropen_external_conventions first_int last_int -+ first_float last_float arg = -+ let loc = Array.create (Array.length arg) Reg.dummy in -+ let int = ref first_int in -+ let float = ref first_float in -+ let ofs = ref (14 * size_addr) in -+ for i = 0 to Array.length arg - 1 do -+ match arg.(i).typ with -+ Int | Addr as ty -> -+ if !int <= last_int then begin -+ loc.(i) <- phys_reg !int; -+ incr int -+ end else begin -+ loc.(i) <- stack_slot (Outgoing !ofs) ty; -+ ofs := !ofs + size_int -+ end -+ | Float -> -+ if !float <= last_float then begin -+ loc.(i) <- phys_reg !float; -+ incr float -+ end else begin -+ loc.(i) <- stack_slot (Outgoing !ofs) Float; -+ ofs := !ofs + size_float -+ end; -+ int := !int + 1 -+ done; -+ (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) -+ -+let loc_external_arguments = -+ match Config.system with -+ | "rhapsody" -> poweropen_external_conventions 0 7 100 112 -+ | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 48 -+ | _ -> assert false -+ -+let extcall_use_push = false -+ -+(* Results are in GPR 3 and FPR 1 *) -+ -+let loc_external_results res = -+ let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc -+ -+(* Exceptions are in GPR 3 *) -+ -+let loc_exn_bucket = phys_reg 0 -+ -+(* Registers destroyed by operations *) -+ -+let destroyed_at_c_call = -+ Array.of_list(List.map phys_reg -+ [0; 1; 2; 3; 4; 5; 6; 7; -+ 100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112]) -+ -+let destroyed_at_oper = function -+ Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs -+ | Iop(Iextcall(_, false)) -> destroyed_at_c_call -+ | _ -> [||] -+ -+let destroyed_at_raise = all_phys_regs -+ -+(* Maximal register pressure *) -+ -+let safe_register_pressure = function -+ Iextcall(_, _) -> 15 -+ | _ -> 23 -+ -+let max_register_pressure = function -+ Iextcall(_, _) -> [| 15; 18 |] -+ | _ -> [| 23; 30 |] -+ -+(* Layout of the stack *) -+ -+let num_stack_slots = [| 0; 0 |] -+let contains_calls = ref false -+ -+(* Calling the assembler *) -+ -+let assemble_file infile outfile = -+ Ccomp.command (Config.asm ^ " -o " ^ -+ Filename.quote outfile ^ " " ^ Filename.quote infile) -+ -+let init () = () -diff --git a/asmcomp/power64le/reload.ml b/asmcomp/power64le/reload.ml -new file mode 100644 -index 0000000..abcac6c ---- /dev/null -+++ b/asmcomp/power64le/reload.ml -@@ -0,0 +1,18 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: reload.ml 2553 1999-11-17 18:59:06Z xleroy $ *) -+ -+(* Reloading for the PowerPC *) -+ -+let fundecl f = -+ (new Reloadgen.reload_generic)#fundecl f -diff --git a/asmcomp/power64le/scheduling.ml b/asmcomp/power64le/scheduling.ml -new file mode 100644 -index 0000000..b7bba9b ---- /dev/null -+++ b/asmcomp/power64le/scheduling.ml -@@ -0,0 +1,65 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1996 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: scheduling.ml 9547 2010-01-22 12:48:24Z doligez $ *) -+ -+(* Instruction scheduling for the Power PC *) -+ -+open Arch -+open Mach -+ -+class scheduler = object -+ -+inherit Schedgen.scheduler_generic -+ -+(* Latencies (in cycles). Based roughly on the "common model". *) -+ -+method oper_latency = function -+ Ireload -> 2 -+ | Iload(_, _) -> 2 -+ | Iconst_float _ -> 2 (* turned into a load *) -+ | Iconst_symbol _ -> 1 -+ | Iintop Imul -> 9 -+ | Iintop_imm(Imul, _) -> 5 -+ | Iintop(Idiv | Imod) -> 36 -+ | Iaddf | Isubf -> 4 -+ | Imulf -> 5 -+ | Idivf -> 33 -+ | Ispecific(Imultaddf | Imultsubf) -> 5 -+ | _ -> 1 -+ -+method reload_retaddr_latency = 12 -+ (* If we can have that many cycles between the reloadretaddr and the -+ return, we can expect that the blr branch will be completely folded. *) -+ -+(* Issue cycles. Rough approximations. *) -+ -+method oper_issue_cycles = function -+ Iconst_float _ | Iconst_symbol _ -> 2 -+ | Iload(_, Ibased(_, _)) -> 2 -+ | Istore(_, Ibased(_, _)) -> 2 -+ | Ialloc _ -> 4 -+ | Iintop(Imod) -> 40 (* assuming full stall *) -+ | Iintop(Icomp _) -> 4 -+ | Iintop_imm(Idiv, _) -> 2 -+ | Iintop_imm(Imod, _) -> 4 -+ | Iintop_imm(Icomp _, _) -> 4 -+ | Ifloatofint -> 9 -+ | Iintoffloat -> 4 -+ | _ -> 1 -+ -+method reload_retaddr_issue_cycles = 3 -+ (* load then stalling mtlr *) -+ -+end -+ -+let fundecl f = (new scheduler)#schedule_fundecl f -diff --git a/asmcomp/power64le/selection.ml b/asmcomp/power64le/selection.ml -new file mode 100644 -index 0000000..6101d53 ---- /dev/null -+++ b/asmcomp/power64le/selection.ml -@@ -0,0 +1,101 @@ -+(***********************************************************************) -+(* *) -+(* Objective Caml *) -+(* *) -+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1997 Institut National de Recherche en Informatique et *) -+(* en Automatique. All rights reserved. This file is distributed *) -+(* under the terms of the Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* $Id: selection.ml 10296 2010-04-22 12:51:06Z xleroy $ *) -+ -+(* Instruction selection for the Power PC processor *) -+ -+open Cmm -+open Arch -+open Mach -+ -+(* Recognition of addressing modes *) -+ -+type addressing_expr = -+ Asymbol of string -+ | Alinear of expression -+ | Aadd of expression * expression -+ -+let rec select_addr = function -+ Cconst_symbol s -> -+ (Asymbol s, 0) -+ | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> -+ let (a, n) = select_addr arg in (a, n + m) -+ | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> -+ let (a, n) = select_addr arg in (a, n + m) -+ | Cop((Caddi | Cadda), [arg1; arg2]) -> -+ begin match (select_addr arg1, select_addr arg2) with -+ ((Alinear e1, n1), (Alinear e2, n2)) -> -+ (Aadd(e1, e2), n1 + n2) -+ | _ -> -+ (Aadd(arg1, arg2), 0) -+ end -+ | exp -> -+ (Alinear exp, 0) -+ -+(* Instruction selection *) -+ -+class selector = object (self) -+ -+inherit Selectgen.selector_generic as super -+ -+method is_immediate n = (n <= 32767) && (n >= -32768) -+ -+method select_addressing chunk exp = -+ match select_addr exp with -+ (Asymbol s, d) -> -+ (Ibased(s, d), Ctuple []) -+ | (Alinear e, d) -> -+ (Iindexed d, e) -+ | (Aadd(e1, e2), d) -> -+ if d = 0 -+ then (Iindexed2, Ctuple[e1; e2]) -+ else (Iindexed d, Cop(Cadda, [e1; e2])) -+ -+method! select_operation op args = -+ match (op, args) with -+ (* Prevent the recognition of (x / cst) and (x % cst) when cst is not -+ a power of 2, which do not correspond to an instruction. *) -+ (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> -+ (Iintop_imm(Idiv, n), [arg]) -+ | (Cdivi, _) -> -+ (Iintop Idiv, args) -+ | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> -+ (Iintop_imm(Imod, n), [arg]) -+ | (Cmodi, _) -> -+ (Iintop Imod, args) -+ (* The and, or and xor instructions have a different range of immediate -+ operands than the other instructions *) -+ | (Cand, _) -> self#select_logical Iand args -+ | (Cor, _) -> self#select_logical Ior args -+ | (Cxor, _) -> self#select_logical Ixor args -+ (* Recognize mult-add and mult-sub instructions *) -+ | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> -+ (Ispecific Imultaddf, [arg1; arg2; arg3]) -+ | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> -+ (Ispecific Imultaddf, [arg1; arg2; arg3]) -+ | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> -+ (Ispecific Imultsubf, [arg1; arg2; arg3]) -+ | _ -> -+ super#select_operation op args -+ -+method select_logical op = function -+ [arg; Cconst_int n] when n >= 0 && n <= 0xFFFF -> -+ (Iintop_imm(op, n), [arg]) -+ | [Cconst_int n; arg] when n >= 0 && n <= 0xFFFF -> -+ (Iintop_imm(op, n), [arg]) -+ | args -> -+ (Iintop op, args) -+ -+end -+ -+let fundecl f = (new selector)#emit_fundecl f -diff --git a/asmrun/Makefile b/asmrun/Makefile -index 6a8ed98..1ff256f 100644 ---- a/asmrun/Makefile -+++ b/asmrun/Makefile -@@ -96,6 +96,12 @@ power64.o: power64-$(SYSTEM).o - power64.p.o: power64-$(SYSTEM).o - cp power64-$(SYSTEM).o power64.p.o - -+power64le.o: power64le-$(SYSTEM).o -+ cp power64le-$(SYSTEM).o power64le.o -+ -+power64le.p.o: power64le-$(SYSTEM).o -+ cp power64le-$(SYSTEM).o power64le.p.o -+ - main.c: ../byterun/main.c - ln -s ../byterun/main.c main.c - misc.c: ../byterun/misc.c -diff --git a/asmrun/power64-elf.S b/asmrun/power64-elf.S -index b2c24d6..98c42e2 100644 ---- a/asmrun/power64-elf.S -+++ b/asmrun/power64-elf.S -@@ -23,12 +23,16 @@ - addis tmp, 0, glob@ha; \ - std reg, glob@l(tmp) - -+#if _CALL_ELF == 2 -+ .abiversion 2 -+#endif - .section ".text" - - /* Invoke the garbage collector. */ - - .globl caml_call_gc - .type caml_call_gc, @function -+#if _CALL_ELF != 2 - .section ".opd","aw" - .align 3 - caml_call_gc: -@@ -36,6 +40,10 @@ caml_call_gc: - .previous - .align 2 - .L.caml_call_gc: -+#else -+caml_call_gc: -+ /* do not set r2 to tocbase */ -+#endif - /* Set up stack frame */ - mflr 0 - std 0, 16(1) -@@ -110,6 +118,7 @@ caml_call_gc: - stfdu 30, 8(11) - stfdu 31, 8(11) - /* Call the GC */ -+#if _CALL_ELF != 2 - std 2,40(1) - Addrglobal(11, caml_garbage_collection) - ld 2,8(11) -@@ -117,6 +126,13 @@ caml_call_gc: - mtlr 11 - blrl - ld 2,40(1) -+#else -+ std 2,24(1) -+ Addrglobal(12, caml_garbage_collection) -+ mtlr 12 -+ blrl -+ ld 2,24(1) -+#endif - /* Reload new allocation pointer and allocation limit */ - Loadglobal(31, caml_young_ptr, 11) - Loadglobal(30, caml_young_limit, 11) -@@ -188,12 +204,17 @@ caml_call_gc: - ld 1, 0(1) - /* Return */ - blr -+#if _CALL_ELF != 2 - .size .L.caml_call_gc,.-.L.caml_call_gc -+#else -+ .size caml_call_gc,.-caml_call_gc -+#endif - - /* Call a C function from Caml */ - - .globl caml_c_call - .type caml_c_call, @function -+#if _CALL_ELF != 2 - .section ".opd","aw" - .align 3 - caml_c_call: -@@ -201,13 +222,21 @@ caml_c_call: - .previous - .align 2 - .L.caml_c_call: -+#else -+caml_c_call: -+0: addis 2,12, .TOC.-0b@ha -+ addi 2, 2, .TOC.-0b@l -+ .localentry caml_c_call, .-caml_c_call -+#endif - .cfi_startproc - /* Save return address */ - mflr 25 - .cfi_register lr,25 - /* Get ready to call C function (address in 11) */ -+#if _CALL_ELF != 2 - ld 2, 8(11) - ld 11,0(11) -+#endif - mtlr 11 - /* Record lowest stack address and return address */ - Storeglobal(1, caml_bottom_of_stack, 12) -@@ -228,12 +257,17 @@ caml_c_call: - /* Return to caller */ - blr - .cfi_endproc -+#if _CALL_ELF != 2 - .size .L.caml_c_call,.-.L.caml_c_call -+#else -+ .size caml_c_call,.-caml_c_call -+#endif - - /* Raise an exception from C */ - - .globl caml_raise_exception - .type caml_raise_exception, @function -+#if _CALL_ELF != 2 - .section ".opd","aw" - .align 3 - caml_raise_exception: -@@ -241,6 +275,12 @@ caml_raise_exception: - .previous - .align 2 - .L.caml_raise_exception: -+#else -+caml_raise_exception: -+0: addis 2,12, .TOC.-0b@ha -+ addi 2, 2, .TOC.-0b@l -+ .localentry caml_raise_exception, .-caml_raise_exception -+#endif - /* Reload Caml global registers */ - Loadglobal(29, caml_exception_pointer, 11) - Loadglobal(31, caml_young_ptr, 11) -@@ -256,12 +296,17 @@ caml_raise_exception: - ld 29, 0(29) - /* Branch to handler */ - blr -+#if _CALL_ELF != 2 - .size .L.caml_raise_exception,.-.L.caml_raise_exception -+#else -+ .size caml_raise_exception,.-caml_raise_exception -+#endif - - /* Start the Caml program */ - - .globl caml_start_program - .type caml_start_program, @function -+#if _CALL_ELF != 2 - .section ".opd","aw" - .align 3 - caml_start_program: -@@ -269,6 +314,9 @@ caml_start_program: - .previous - .align 2 - .L.caml_start_program: -+#else -+caml_start_program: -+#endif - Addrglobal(12, caml_program) - - /* Code shared between caml_start_program and caml_callback */ -@@ -342,6 +390,7 @@ caml_start_program: - li 0, 0 - Storeglobal(0, caml_last_return_address, 11) - /* Call the Caml code */ -+#if _CALL_ELF != 2 - std 2,40(1) - ld 2,8(12) - ld 12,0(12) -@@ -349,6 +398,13 @@ caml_start_program: - .L105: - blrl - ld 2,40(1) -+#else -+ std 2,24(1) -+ mtlr 12 -+.L105: -+ blrl -+ ld 2,24(1) -+#endif - /* Pop the trap frame, restoring caml_exception_pointer */ - ld 9, 0x170(1) - Storeglobal(9, caml_exception_pointer, 11) -@@ -414,12 +470,17 @@ caml_start_program: - /* Encode exception bucket as an exception result and return it */ - ori 3, 3, 2 - b .L106 -+#if _CALL_ELF != 2 - .size .L.caml_start_program,.-.L.caml_start_program -+#else -+ .size caml_start_program,.-caml_start_program -+#endif - - /* Callback from C to Caml */ - - .globl caml_callback_exn - .type caml_callback_exn, @function -+#if _CALL_ELF != 2 - .section ".opd","aw" - .align 3 - caml_callback_exn: -@@ -427,17 +488,28 @@ caml_callback_exn: - .previous - .align 2 - .L.caml_callback_exn: -+#else -+caml_callback_exn: -+0: addis 2,12, .TOC.-0b@ha -+ addi 2, 2, .TOC.-0b@l -+ .localentry caml_callback_exn, .-caml_callback_exn -+#endif - /* Initial shuffling of arguments */ - mr 0, 3 /* Closure */ - mr 3, 4 /* Argument */ - mr 4, 0 - ld 12, 0(4) /* Code pointer */ - b .L102 -+#if _CALL_ELF != 2 - .size .L.caml_callback_exn,.-.L.caml_callback_exn -+#else -+ .size caml_callback_exn,.-caml_callback_exn -+#endif -+ - -- - .globl caml_callback2_exn - .type caml_callback2_exn, @function -+#if _CALL_ELF != 2 - .section ".opd","aw" - .align 3 - caml_callback2_exn: -@@ -445,17 +517,28 @@ caml_callback2_exn: - .previous - .align 2 - .L.caml_callback2_exn: -+#else -+caml_callback2_exn: -+0: addis 2,12, .TOC.-0b@ha -+ addi 2, 2, .TOC.-0b@l -+ .localentry caml_callback2_exn, .-caml_callback2_exn -+#endif - mr 0, 3 /* Closure */ - mr 3, 4 /* First argument */ - mr 4, 5 /* Second argument */ - mr 5, 0 - Addrglobal(12, caml_apply2) - b .L102 -+#if _CALL_ELF != 2 - .size .L.caml_callback2_exn,.-.L.caml_callback2_exn -+#else -+ .size caml_callback2_exn,.-caml_callback2_exn -+#endif - - - .globl caml_callback3_exn - .type caml_callback3_exn, @function -+#if _CALL_ELF != 2 - .section ".opd","aw" - .align 3 - caml_callback3_exn: -@@ -463,6 +546,12 @@ caml_callback3_exn: - .previous - .align 2 - .L.caml_callback3_exn: -+#else -+caml_callback3_exn: -+0: addis 2,12, .TOC.-0b@ha -+ addi 2, 2, .TOC.-0b@l -+ .localentry caml_callback3_exn, .-caml_callback3_exn -+#endif - mr 0, 3 /* Closure */ - mr 3, 4 /* First argument */ - mr 4, 5 /* Second argument */ -@@ -470,7 +559,11 @@ caml_callback3_exn: - mr 6, 0 - Addrglobal(12, caml_apply3) - b .L102 -+#if _CALL_ELF != 2 - .size .L.caml_callback3_exn,.-.L.caml_callback3_exn -+#else -+ .size caml_callback3_exn,.-caml_callback3_exn -+#endif - - /* Frame table */ - -diff --git a/asmrun/power64le-elf.S b/asmrun/power64le-elf.S -new file mode 120000 -index 0000000..f49d00c ---- /dev/null -+++ b/asmrun/power64le-elf.S -@@ -0,0 +1 @@ -+power64-elf.S -\ No newline at end of file -diff --git a/asmrun/stack.h b/asmrun/stack.h -index 031e408..f1890c1 100644 ---- a/asmrun/stack.h -+++ b/asmrun/stack.h -@@ -55,6 +55,15 @@ - #define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) - #endif - -+#ifdef TARGET_power64le -+#define Saved_return_address(sp) *((intnat *)((sp) +16)) -+#define Already_scanned(sp, retaddr) ((retaddr) & 1) -+#define Mark_scanned(sp, retaddr) (Saved_return_address(sp) = (retaddr) | 1) -+#define Mask_already_scanned(retaddr) ((retaddr) & ~1) -+#define Trap_frame_size 0x150 -+#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) -+#endif -+ - #ifdef TARGET_arm - #define Saved_return_address(sp) *((intnat *)((sp) - 4)) - #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -diff --git a/config/gnu/config.guess b/config/gnu/config.guess -index b79252d..049652e 100755 ---- a/config/gnu/config.guess -+++ b/config/gnu/config.guess -@@ -992,6 +992,9 @@ EOF - ppc64:Linux:*:*) - echo powerpc64-unknown-linux-${LIBC} - exit ;; -+ ppc64le:Linux:*:*) -+ echo powerpc64le-unknown-linux-gnu -+ exit ;; - ppc:Linux:*:*) - echo powerpc-unknown-linux-${LIBC} - exit ;; -diff --git a/configure b/configure -index a0e1466..3bd98ad 100755 ---- a/configure -+++ b/configure -@@ -700,6 +700,7 @@ case "$host" in - fi;; - i[3456]86-*-gnu*) arch=i386; system=gnu;; - powerpc64-*-linux*) arch=power64; model=ppc64; system=elf;; -+ powerpc64le-*-linux*) arch=power64le; model=ppc64le; system=elf;; - powerpc*-*-linux*) arch=power; model=ppc; system=elf;; - powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; - powerpc-*-openbsd*) arch=power; model=ppc; system=bsd_elf;; -@@ -786,6 +787,8 @@ case "$arch,$model,$system" in - aspp='gcc -c';; - power64,*,elf) as='as -u -m ppc64' - aspp='gcc -c';; -+ power64le,*,elf) as='as -u -m ppc64' -+ aspp='gcc -c';; - power,*,rhapsody) as="as -arch $model" - aspp="$bytecc -c";; - sparc,*,solaris) as='as' --- -1.8.3.1 - diff --git a/SOURCES/0014-arm-arm64-Mark-stack-as-non-executable.patch b/SOURCES/0014-arm-arm64-Mark-stack-as-non-executable.patch deleted file mode 100644 index 85dfa80..0000000 --- a/SOURCES/0014-arm-arm64-Mark-stack-as-non-executable.patch +++ /dev/null @@ -1,39 +0,0 @@ -From 262882b5fe2d327170f33a28dc35866aa32af84e Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Sat, 10 May 2014 03:20:35 -0400 -Subject: [PATCH 14/19] arm, arm64: Mark stack as non-executable. - -The same fix as this one, which was only fully applied to -i686 & x86-64: - -http://caml.inria.fr/mantis/view.php?id=4564 ---- - asmrun/arm.S | 3 +++ - asmrun/arm64.S | 3 +++ - 2 files changed, 6 insertions(+) - -diff --git a/asmrun/arm.S b/asmrun/arm.S -index 2ce244a..90f5b6e 100644 ---- a/asmrun/arm.S -+++ b/asmrun/arm.S -@@ -489,3 +489,6 @@ caml_system__frametable: - .align 2 - .type caml_system__frametable, %object - .size caml_system__frametable, .-caml_system__frametable -+ -+ /* Mark stack as non-executable, PR#4564 */ -+ .section .note.GNU-stack,"",%progbits -diff --git a/asmrun/arm64.S b/asmrun/arm64.S -index de670e6..84e18ba 100644 ---- a/asmrun/arm64.S -+++ b/asmrun/arm64.S -@@ -533,3 +533,6 @@ caml_system__frametable: - .align 3 - .type caml_system__frametable, %object - .size caml_system__frametable, .-caml_system__frametable -+ -+ /* Mark stack as non-executable, PR#4564 */ -+ .section .note.GNU-stack,"",%progbits --- -1.8.3.1 - diff --git a/SOURCES/0015-ppc-ppc64-ppc64le-Mark-stack-as-non-executable.patch b/SOURCES/0015-ppc-ppc64-ppc64le-Mark-stack-as-non-executable.patch deleted file mode 100644 index 8f759a0..0000000 --- a/SOURCES/0015-ppc-ppc64-ppc64le-Mark-stack-as-non-executable.patch +++ /dev/null @@ -1,74 +0,0 @@ -From ceaad702cd43142053795acb7224251c51088e24 Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Thu, 11 Sep 2014 14:49:54 +0100 -Subject: [PATCH 15/19] ppc, ppc64, ppc64le: Mark stack as non-executable. - -The same fix as this one, which was only fully applied to -i686 & x86-64: - -http://caml.inria.fr/mantis/view.php?id=4564 ---- - asmcomp/power/emit.mlp | 3 ++- - asmcomp/power64/emit.mlp | 3 ++- - asmcomp/power64le/emit.mlp | 3 ++- - asmrun/power-elf.S | 3 +++ - asmrun/power64-elf.S | 2 ++ - 5 files changed, 11 insertions(+), 3 deletions(-) - -diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp -index 283312e..8df22d3 100644 ---- a/asmcomp/power/emit.mlp -+++ b/asmcomp/power/emit.mlp -@@ -976,4 +976,5 @@ let end_assembly() = - ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); - efa_def_label = (fun l -> `{emit_label l}:\n`); - efa_string = (fun s -> emit_bytes_directive " .byte " (s ^ "\000")) -- } -+ }; -+ `.section .note.GNU-stack,\"\",%progbits; .previous\n` -diff --git a/asmcomp/power64/emit.mlp b/asmcomp/power64/emit.mlp -index d84ac5c..618095e 100644 ---- a/asmcomp/power64/emit.mlp -+++ b/asmcomp/power64/emit.mlp -@@ -985,4 +985,5 @@ let end_assembly() = - `{emit_symbol lbl}:\n`; - ` .quad {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; -- frame_descriptors := [] -+ frame_descriptors := []; -+ `.section .note.GNU-stack,\"\",%progbits; .previous\n` -diff --git a/asmcomp/power64le/emit.mlp b/asmcomp/power64le/emit.mlp -index 5736a18..9ec7cd8 100644 ---- a/asmcomp/power64le/emit.mlp -+++ b/asmcomp/power64le/emit.mlp -@@ -978,4 +978,5 @@ let end_assembly() = - `{emit_symbol lbl}:\n`; - ` .quad {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; -- frame_descriptors := [] -+ frame_descriptors := []; -+ `.section .note.GNU-stack,\"\",%progbits; .previous\n` -diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S -index 94f4a29..1e8541f 100644 ---- a/asmrun/power-elf.S -+++ b/asmrun/power-elf.S -@@ -422,3 +422,6 @@ caml_system__frametable: - .long .L105 + 4 /* return address into callback */ - .short -1 /* negative size count => use callback link */ - .short 0 /* no roots here */ -+ -+/* Mark stack as non-executable, PR#4564 */ -+ .section .note.GNU-stack,"",%progbits -diff --git a/asmrun/power64-elf.S b/asmrun/power64-elf.S -index 98c42e2..b7bfce4 100644 ---- a/asmrun/power64-elf.S -+++ b/asmrun/power64-elf.S -@@ -577,3 +577,5 @@ caml_system__frametable: - .short 0 /* no roots here */ - .align 3 - -+/* Mark stack as non-executable, PR#4564 */ -+ .section .note.GNU-stack,"",%progbits --- -1.8.3.1 - diff --git a/SOURCES/0016-mantis-6489-fix-by-Richard-Jones.patch b/SOURCES/0016-mantis-6489-fix-by-Richard-Jones.patch deleted file mode 100644 index b643d62..0000000 --- a/SOURCES/0016-mantis-6489-fix-by-Richard-Jones.patch +++ /dev/null @@ -1,26 +0,0 @@ -From 30333c49ca23c16465f9dfd1b8539c31c1530788 Mon Sep 17 00:00:00 2001 -From: Mark Shinwell -Date: Wed, 16 Jul 2014 06:35:17 +0000 -Subject: [PATCH 16/19] mantis 6489 (fix by Richard Jones) - -git-svn-id: http://caml.inria.fr/svn/ocaml/version/4.02@15001 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 ---- - asmrun/arm64.S | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/asmrun/arm64.S b/asmrun/arm64.S -index 84e18ba..387f5dc 100644 ---- a/asmrun/arm64.S -+++ b/asmrun/arm64.S -@@ -478,7 +478,7 @@ caml_callback2_exn: - /* Initial shuffling of arguments (x0 = closure, x1 = arg1, x2 = arg2) */ - mov TMP, x0 - mov x0, x1 /* x0 = first arg */ -- mov x1, x2 /* x1 = second arg -+ mov x1, x2 /* x1 = second arg */ - mov x2, TMP /* x2 = closure environment */ - ADDRGLOBAL(ARG, caml_apply2) - b .Ljump_to_caml --- -1.8.3.1 - diff --git a/SOURCES/0017-ppc64le-Fix-calling-convention-of-external-functions.patch b/SOURCES/0017-ppc64le-Fix-calling-convention-of-external-functions.patch deleted file mode 100644 index e061b37..0000000 --- a/SOURCES/0017-ppc64le-Fix-calling-convention-of-external-functions.patch +++ /dev/null @@ -1,34 +0,0 @@ -From 50b945d8c5e66d963815207a1cc8158f8b60e0e2 Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Thu, 28 May 2015 16:13:40 -0400 -Subject: [PATCH 17/19] ppc64le: Fix calling convention of external functions - with > 8 parameters (RHBZ#1225995). - -For external (ie. C) functions with more than 8 parameters, we must -pass the first 8 parameters in registers and then all the remaining -parameters on the stack. - -Unfortunately the original backend copied the stack offset from ppc64, -where it works, but the offset was wrong for ppc64le. - -By experimentation I found the correct offset. ---- - asmcomp/power64le/proc.ml | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/asmcomp/power64le/proc.ml b/asmcomp/power64le/proc.ml -index 9b98577..30d4cdc 100644 ---- a/asmcomp/power64le/proc.ml -+++ b/asmcomp/power64le/proc.ml -@@ -188,7 +188,7 @@ let poweropen_external_conventions first_int last_int - let loc_external_arguments = - match Config.system with - | "rhapsody" -> poweropen_external_conventions 0 7 100 112 -- | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 48 -+ | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 32 - | _ -> assert false - - let extcall_use_push = false --- -1.8.3.1 - diff --git a/SOURCES/0018-ppc64-ppc64le-Fix-behaviour-of-Int64.max_int-1-RHBZ-.patch b/SOURCES/0018-ppc64-ppc64le-Fix-behaviour-of-Int64.max_int-1-RHBZ-.patch deleted file mode 100644 index f856b4c..0000000 --- a/SOURCES/0018-ppc64-ppc64le-Fix-behaviour-of-Int64.max_int-1-RHBZ-.patch +++ /dev/null @@ -1,47 +0,0 @@ -From 0d958fae8fcb4b80784c3329bb0033388a35e396 Mon Sep 17 00:00:00 2001 -From: "Richard W.M. Jones" -Date: Mon, 29 Jun 2015 14:18:38 -0400 -Subject: [PATCH 18/19] =?UTF-8?q?ppc64/ppc64le:=20Fix=20behaviour=20of=20I?= - =?UTF-8?q?nt64.max=5Fint=20=C3=B7=20-1=20(RHBZ#1236615).?= -MIME-Version: 1.0 -Content-Type: text/plain; charset=UTF-8 -Content-Transfer-Encoding: 8bit - -I only tested this on ppc64le, but assume the behaviour is the -same on ppc64. - -(cherry picked from commit cf026cf66315609afe8f76272e493259bade255f) ---- - asmcomp/power64/arch.ml | 2 +- - asmcomp/power64le/arch.ml | 2 +- - 2 files changed, 2 insertions(+), 2 deletions(-) - -diff --git a/asmcomp/power64/arch.ml b/asmcomp/power64/arch.ml -index 73c516d..ccd11fc 100644 ---- a/asmcomp/power64/arch.ml -+++ b/asmcomp/power64/arch.ml -@@ -46,7 +46,7 @@ let allow_unaligned_access = false - - (* Behavior of division *) - --let division_crashes_on_overflow = false -+let division_crashes_on_overflow = true - - (* Operations on addressing modes *) - -diff --git a/asmcomp/power64le/arch.ml b/asmcomp/power64le/arch.ml -index 586534b..2155e79 100644 ---- a/asmcomp/power64le/arch.ml -+++ b/asmcomp/power64le/arch.ml -@@ -46,7 +46,7 @@ let allow_unaligned_access = false - - (* Behavior of division *) - --let division_crashes_on_overflow = false -+let division_crashes_on_overflow = true - - (* Operations on addressing modes *) - --- -1.8.3.1 - diff --git a/SOURCES/0019-fix-PR-7003-and-a-few-other-bugs-caused-by-misuse-of.patch b/SOURCES/0019-fix-PR-7003-and-a-few-other-bugs-caused-by-misuse-of.patch deleted file mode 100644 index 6ea42eb..0000000 --- a/SOURCES/0019-fix-PR-7003-and-a-few-other-bugs-caused-by-misuse-of.patch +++ /dev/null @@ -1,59 +0,0 @@ -From 18c7b7f4d6ef0a1a8fc99f98133326dc1674b97f Mon Sep 17 00:00:00 2001 -From: Damien Doligez -Date: Mon, 19 Oct 2015 15:47:33 +0000 -Subject: [PATCH 19/19] fix PR#7003 and a few other bugs caused by misuse of - Int_val - -git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@16525 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 -(cherry picked from commit 659615c7b100a89eafe6253e7a5b9d84d0e8df74) ---- - byterun/alloc.c | 4 ++-- - byterun/str.c | 4 ++-- - 2 files changed, 4 insertions(+), 4 deletions(-) - -diff --git a/byterun/alloc.c b/byterun/alloc.c -index a1fd2f0..dfbdfb8 100644 ---- a/byterun/alloc.c -+++ b/byterun/alloc.c -@@ -145,7 +145,7 @@ CAMLexport int caml_convert_flag_list(value list, int *flags) - - CAMLprim value caml_alloc_dummy(value size) - { -- mlsize_t wosize = Int_val(size); -+ mlsize_t wosize = Long_val(size); - - if (wosize == 0) return Atom(0); - return caml_alloc (wosize, 0); -@@ -153,7 +153,7 @@ CAMLprim value caml_alloc_dummy(value size) - - CAMLprim value caml_alloc_dummy_float (value size) - { -- mlsize_t wosize = Int_val(size) * Double_wosize; -+ mlsize_t wosize = Long_val(size) * Double_wosize; - - if (wosize == 0) return Atom(0); - return caml_alloc (wosize, 0); -diff --git a/byterun/str.c b/byterun/str.c -index 9a96147..d4d9a8d 100644 ---- a/byterun/str.c -+++ b/byterun/str.c -@@ -269,7 +269,7 @@ CAMLprim value caml_string_greaterequal(value s1, value s2) - CAMLprim value caml_blit_string(value s1, value ofs1, value s2, value ofs2, - value n) - { -- memmove(&Byte(s2, Long_val(ofs2)), &Byte(s1, Long_val(ofs1)), Int_val(n)); -+ memmove(&Byte(s2, Long_val(ofs2)), &Byte(s1, Long_val(ofs1)), Long_val(n)); - return Val_unit; - } - -@@ -296,6 +296,6 @@ CAMLprim value caml_is_printable(value chr) - - CAMLprim value caml_bitvect_test(value bv, value n) - { -- int pos = Int_val(n); -+ intnat pos = Long_val(n); - return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7))); - } --- -1.8.3.1 - diff --git a/SOURCES/macros.ocaml-srpm b/SOURCES/macros.ocaml-srpm deleted file mode 100644 index 7b8d319..0000000 --- a/SOURCES/macros.ocaml-srpm +++ /dev/null @@ -1,10 +0,0 @@ -# Note that OCaml is compiled on all architectures. However -# on some (rare) architectures, only bytecode compilation is -# available. Use these macros to find out if native code -# compilation is available on a particular architecture. - -# Architectures that support the OCaml native code compiler. -%ocaml_native_compiler aarch64 %{arm} %{ix86} ppc ppc64 ppc64le sparc sparcv9 x86_64 - -# Architectures that support native dynamic linking of OCaml code. -%ocaml_natdynlink aarch64 %{arm} %{ix86} ppc ppc64 ppc64le sparc sparcv9 x86_64 diff --git a/SPECS/ocaml.spec b/SPECS/ocaml.spec index 02004a4..e5c7d4d 100644 --- a/SPECS/ocaml.spec +++ b/SPECS/ocaml.spec @@ -1,14 +1,8 @@ -%global macros_dir %{_rpmconfigdir}/macros.d - # OCaml has a bytecode backend that works on anything with a C # compiler, and a native code backend available on a subset of # architectures. A further subset of architectures support native # dynamic linking. -# NB. These must match the contents of macros.ocaml-srpm precisely! -%global ocaml_native_compiler aarch64 %{arm} %{ix86} ppc ppc64 ppc64le sparc sparcv9 x86_64 -%global ocaml_natdynlink aarch64 %{arm} %{ix86} ppc ppc64 ppc64le sparc sparcv9 x86_64 - %ifarch %{ocaml_native_compiler} %global native_compiler 1 %else @@ -21,9 +15,22 @@ %global natdynlink 0 %endif +# These are all the architectures that the tests run on. The tests +# take a long time to run, so don't run them on slow machines. +# - ppc64: tests hang under Koji with: +# Thread 1 killed on uncaught exception Unix.Unix_error(25, "accept", "") +# Unable to reproduce this failure locally. +%global test_arches aarch64 ppc64le x86_64 +# These are the architectures for which the tests must pass otherwise +# the build will fail. +%global test_arches_required aarch64 ppc64le x86_64 + +# Architectures where parallel builds fail. +#%global no_parallel_build_arches aarch64 + Name: ocaml -Version: 4.01.0 -Release: 22.7%{?dist} +Version: 4.05.0 +Release: 6%{?dist} Summary: OCaml compiler and programming environment @@ -31,82 +38,57 @@ License: QPL and (LGPLv2+ with exceptions) URL: http://www.ocaml.org -# After ocaml 4.01.0 was released, upstream added some patches and -# fixes to the git repository, but did not make a further tarball -# release. The Source0 file here reflects the final git release of 4.01.0. -# To reconstruct this archive, do: -# git archive --prefix=ocaml-4.01.0/ --output=ocaml-ecc80c0d3850bc144760af4c63b7eab438615bdc.tar ecc80c0d3850bc144760af4c63b7eab438615bdc -# gzip --best ocaml-ecc80c0d3850bc144760af4c63b7eab438615bdc.tar -Source0: ocaml-ecc80c0d3850bc144760af4c63b7eab438615bdc.tar.gz -Source1: http://caml.inria.fr/pub/distrib/ocaml-4.01/ocaml-4.01-refman-html.tar.gz -Source2: http://caml.inria.fr/pub/distrib/ocaml-4.01/ocaml-4.01-refman.pdf -Source3: http://caml.inria.fr/pub/distrib/ocaml-4.01/ocaml-4.01-refman.info.tar.gz +Source0: http://caml.inria.fr/pub/distrib/ocaml-4.05/ocaml-%{version}.tar.xz -# In Fedora this is in a separate package (ocaml-srpm-macros). -Source4: macros.ocaml-srpm +Source1: http://caml.inria.fr/pub/distrib/ocaml-4.05/ocaml-4.05-refman-html.tar.gz +Source2: http://caml.inria.fr/pub/distrib/ocaml-4.05/ocaml-4.05-refman.pdf +Source3: http://caml.inria.fr/pub/distrib/ocaml-4.05/ocaml-4.05-refman.info.tar.gz # IMPORTANT NOTE: # # These patches are generated from unpacked sources stored in a -# fedorahosted git repository. If you change the patches here, they -# will be OVERWRITTEN by the next update. Instead, request commit -# access to the fedorahosted project: +# pagure.io git repository. If you change the patches here, they will +# be OVERWRITTEN by the next update. Instead, request commit access +# to the pagure project: # -# https://git.fedorahosted.org/cgit/fedora-ocaml.git/ +# https://pagure.io/fedora-ocaml # -# Current branch: rhel-7-4.01.0 +# Current branch: rhel-7.5-4.05.0 # # ALTERNATIVELY add a patch to the end of the list (leaving the # existing patches unchanged) adding a comment to note that it should # be incorporated into the git repo at a later time. # -Patch0001: 0001-Add-.gitignore-file-to-ignore-generated-files.patch -Patch0002: 0002-Ensure-empty-compilerlibs-directory-is-created-by-gi.patch -Patch0003: 0003-ocamlbyteinfo-ocamlplugininfo-Useful-utilities-from-.patch -Patch0004: 0004-Don-t-add-rpaths-to-libraries.patch -Patch0005: 0005-configure-Allow-user-defined-C-compiler-flags.patch -Patch0006: 0006-Add-support-for-ppc64.patch -Patch0007: 0007-yacc-Use-mkstemp-instead-of-mktemp.patch - -# Aarch64 patches. -Patch0008: 0008-Port-to-the-ARM-64-bits-AArch64-architecture-experim.patch -Patch0009: 0009-Updated-with-latest-versions-from-FSF.patch -Patch0010: 0010-arm64-Align-code-and-data-to-8-bytes.patch - -# NON-upstream patch to allow '--flag=arg' as an alternative to '--flag arg'. -Patch0011: 0011-arg-Add-no_arg-and-get_arg-helper-functions.patch -Patch0012: 0012-arg-Allow-flags-such-as-flag-arg-as-well-as-flag-arg.patch -# ppc64le support (Michel Normand). -Patch0013: 0013-Add-support-for-ppc64le.patch +# Upstream patches after 4.05. +Patch0001: 0001-Changes-clarify-compatibility-breaking-change-items.patch +Patch0002: 0002-MPR-7591-frametable-not-8-aligned-on-x86-64-port.patch +Patch0003: 0003-Fixes-for-out-of-range-Ialloc.patch -# ARM & Aarch64 non-executable stack. -Patch0014: 0014-arm-arm64-Mark-stack-as-non-executable.patch - -# ppc, ppc64, ppc64le non-executable stack. -Patch0015: 0015-ppc-ppc64-ppc64le-Mark-stack-as-non-executable.patch - -# aarch64: caml_callback2 crashes (upstream PR#6489, RHBZ#1193037). -Patch0016: 0016-mantis-6489-fix-by-Richard-Jones.patch - -# ppc64le: Fix calling convention of external functions with > 8 params -# (RHBZ#1225995). -Patch0017: 0017-ppc64le-Fix-calling-convention-of-external-functions.patch - -# ppc64le: Fix behaviour of Int64.max_int ÷ -1 (RHBZ#1236615). -Patch0018: 0018-ppc64-ppc64le-Fix-behaviour-of-Int64.max_int-1-RHBZ-.patch - -# Fix buffer overflow and information leak CVE-2015-8869 (RHBZ#1343081). -Patch0019: 0019-fix-PR-7003-and-a-few-other-bugs-caused-by-misuse-of.patch - -# Add BFD support so that ocamlobjinfo supports *.cmxs format (RHBZ#1113735). +# Fedora-specific downstream patches. +Patch0004: 0004-Don-t-add-rpaths-to-libraries.patch +Patch0005: 0005-ocamlbyteinfo-ocamlplugininfo-Useful-utilities-from-.patch +Patch0006: 0006-configure-Allow-user-defined-C-compiler-flags.patch + +# Out of tree patches for RISC-V support. +# https://github.com/nojb/riscv-ocaml +Patch0007: 0007-Adapt-config.guess-for-RISC-V.patch +Patch0008: 0008-Add-RISC-V-backend-runtime.patch +Patch0009: 0009-Try-fix-for-andi-ori-xori-immediates-1.patch +Patch0010: 0010-Fix-immediates-range-when-adjusting-indexing-sp.patch +Patch0011: 0011-Another-immediate-range-fix.patch + +# Fix for some aarch64 linker problems. +# https://caml.inria.fr/mantis/view.php?id=7585 +Patch0012: 0012-AArch64-GOT-fixed.patch + +BuildRequires: ocaml-srpm-macros BuildRequires: binutils-devel - BuildRequires: ncurses-devel BuildRequires: gdbm-devel -BuildRequires: tcl-devel -BuildRequires: tk-devel +%ifnarch riscv64 BuildRequires: emacs +%endif BuildRequires: gawk BuildRequires: perl BuildRequires: util-linux @@ -123,19 +105,26 @@ BuildRequires: mesa-libGL-devel BuildRequires: mesa-libGLU-devel BuildRequires: chrpath -# git is required for patch management. -BuildRequires: git - +Requires: ocaml-srpm-macros Requires: gcc -Requires: rpm-build >= 4.8.0 + +# Because we pass -c flag to ocaml-find-requires (to avoid circular +# dependencies) we also have to explicitly depend on the right version +# of ocaml-runtime. +Requires: ocaml-runtime = %{version}-%{release} # Bundles an MD5 implementation in byterun/md5.{c,h} Provides: bundled(md5-plumb) Provides: ocaml(compiler) = %{version} -%global __ocaml_requires_opts -c -f '%{buildroot}%{_bindir}/ocamlrun %{buildroot}%{_bindir}/ocamlobjinfo' -%global __ocaml_provides_opts -f '%{buildroot}%{_bindir}/ocamlrun %{buildroot}%{_bindir}/ocamlobjinfo' +# These subpackages were removed in RHEL 7.5. It is intended that +# they will be replaced by new packages in EPEL. +Obsoletes: ocaml-labltk <= %{version}-%{release} +Obsoletes: ocaml-labltk-devel <= %{version}-%{release} + +%global __ocaml_requires_opts -c -f '%{buildroot}%{_bindir}/ocamlrun %{buildroot}%{_bindir}/ocamlobjinfo.byte' +%global __ocaml_provides_opts -f '%{buildroot}%{_bindir}/ocamlrun %{buildroot}%{_bindir}/ocamlobjinfo.byte' %description @@ -144,7 +133,7 @@ programming language from the ML family of languages. This package comprises two batch compilers (a fast bytecode compiler and an optimizing native-code compiler), an interactive toplevel system, -parsing tools (Lex,Yacc,Camlp4), a replay debugger, a documentation generator, +parsing tools (Lex,Yacc), a replay debugger, a documentation generator, and a comprehensive library. @@ -152,9 +141,6 @@ and a comprehensive library. Summary: OCaml runtime environment Requires: util-linux Provides: ocaml(runtime) = %{version} -# This is a hack because ocamlrun -version now prints 4.01.1, which -# was never a real version, but rebuilt packages will depend on this. -Provides: ocaml(runtime) = 4.01.1 %description runtime OCaml is a high-level, strongly-typed, functional and object-oriented @@ -181,56 +167,6 @@ Requires: libX11-devel X11 support for OCaml. -%package labltk -Summary: Tk bindings for OCaml -Requires: ocaml-runtime = %{version}-%{release} - -%description labltk -Labltk is a library for interfacing OCaml with the scripting language -Tcl/Tk. - -This package contains the runtime files. - - -%package labltk-devel -Summary: Development files for labltk -Requires: ocaml = %{version}-%{release} -Requires: %{name}-labltk = %{version}-%{release} -Requires: libX11-devel -Requires: tcl-devel -Requires: tk-devel - -%description labltk-devel -Labltk is a library for interfacing OCaml with the scripting language -Tcl/Tk. - -This package contains the development files. It includes the ocaml -browser for code editing and library browsing. - - -%package camlp4 -Summary: Pre-Processor-Pretty-Printer for OCaml -Requires: ocaml-runtime = %{version}-%{release} - -%description camlp4 -Camlp4 is a Pre-Processor-Pretty-Printer for OCaml, parsing a source -file and printing some result on standard output. - -This package contains the runtime files. - - -%package camlp4-devel -Summary: Pre-Processor-Pretty-Printer for OCaml -Requires: ocaml = %{version}-%{release} -Requires: %{name}-camlp4 = %{version}-%{release} - -%description camlp4-devel -Camlp4 is a Pre-Processor-Pretty-Printer for OCaml, parsing a source -file and printing some result on standard output. - -This package contains the development files. - - %package ocamldoc Summary: Documentation generator for OCaml Requires: ocaml = %{version}-%{release} @@ -240,13 +176,15 @@ Provides: ocamldoc Documentation generator for OCaml. +%ifnarch riscv64 %package emacs Summary: Emacs mode for OCaml Requires: ocaml = %{version}-%{release} -Requires: emacs +Requires: emacs(bin) %description emacs Emacs mode for OCaml. +%endif %package docs @@ -284,37 +222,20 @@ may not be portable between versions. %setup -q -T -D -a 1 -n %{name}-%{version} %setup -q -T -D -a 3 -n %{name}-%{version} cp %{SOURCE2} refman.pdf - -git init -git config user.email "noone@example.com" -git config user.name "no one" -git add . -git commit -a -q -m "%{version} baseline" -git am %{patches} 1) breaks the build. Therefore we cannot use -# %{?_smp_mflags} nor MAKEFLAGS. +# Parallel builds are broken in 4.05.0, see +# https://caml.inria.fr/mantis/view.php?id=7587 +#%ifnarch %{no_parallel_build_arches} +#make="make %{?_smp_mflags}" +#%else unset MAKEFLAGS +make=make +#%endif -# For ppc64 we need a larger stack than default to compile some files -# because the stages in the OCaml compiler are not mutually tail -# recursive. -%ifarch ppc64 ppc64le -ulimit -a -ulimit -Hs 65536 -ulimit -Ss 65536 -%endif - -# For the use of -mpreferred-stack-boundary to workaround gcc stack -# alignment issues, see: http://caml.inria.fr/mantis/view.php?id=5700 -# ONLY use this on i386. -%ifarch %{ix86} -CFLAGS="$RPM_OPT_FLAGS -fno-strict-aliasing -mpreferred-stack-boundary=2" \ -%else CFLAGS="$RPM_OPT_FLAGS -fno-strict-aliasing" \ -%endif ./configure \ -bindir %{_bindir} \ -libdir %{_libdir}/ocaml \ @@ -322,11 +243,14 @@ CFLAGS="$RPM_OPT_FLAGS -fno-strict-aliasing" \ -x11include %{_includedir} \ -mandir %{_mandir}/man1 \ -no-curses -make world +$make world %if %{native_compiler} -make opt opt.opt +$make opt +$make opt.opt %endif +%ifnarch riscv64 make -C emacs ocamltags +%endif # Currently these tools are supplied by Debian, but are expected # to go upstream at some point. @@ -338,6 +262,18 @@ boot/ocamlrun ./ocamlc $includes dynlinkaux.cmo ocamlbyteinfo.ml -o ocamlbyteinf #boot/ocamlrun ./ocamlopt $includes unix.cmxa str.cmxa natdynlink.ml ocamlplugininfo.ml -o ocamlplugininfo +%check +%ifarch %{test_arches} +cd testsuite + +%ifarch %{test_arches_required} +make -j1 all +%else +make -j1 all ||: +%endif +%endif + + %install make install \ BINDIR=$RPM_BUILD_ROOT%{_bindir} \ @@ -345,6 +281,7 @@ make install \ MANDIR=$RPM_BUILD_ROOT%{_mandir} perl -pi -e "s|^$RPM_BUILD_ROOT||" $RPM_BUILD_ROOT%{_libdir}/ocaml/ld.conf +%ifnarch riscv64 ( # install emacs files cd emacs; @@ -353,6 +290,7 @@ perl -pi -e "s|^$RPM_BUILD_ROOT||" $RPM_BUILD_ROOT%{_libdir}/ocaml/ld.conf EMACSDIR=$RPM_BUILD_ROOT%{_datadir}/emacs/site-lisp make install-ocamltags BINDIR=$RPM_BUILD_ROOT%{_bindir} ) +%endif ( # install info files @@ -370,8 +308,9 @@ install -m 0755 ocamlbyteinfo $RPM_BUILD_ROOT%{_bindir} find $RPM_BUILD_ROOT -name .ignore -delete -mkdir -p $RPM_BUILD_ROOT%{macros_dir} -install -m 0644 %{SOURCE0} $RPM_BUILD_ROOT%{macros_dir}/macros.ocaml-srpm +# Remove .cmt and .cmti files, for now. We could package them later. +# See also: http://www.ocamlpro.com/blog/2012/08/20/ocamlpro-and-4.00.0.html +find $RPM_BUILD_ROOT \( -name '*.cmt' -o -name '*.cmti' \) -a -delete %post docs @@ -391,37 +330,53 @@ fi %files %doc LICENSE %{_bindir}/ocaml + %{_bindir}/ocamlbyteinfo -%{_bindir}/ocamlbuild -%{_bindir}/ocamlbuild.byte -%if %{native_compiler} -%{_bindir}/ocamlbuild.native -%endif +%{_bindir}/ocamldebug +#%{_bindir}/ocamlplugininfo +%{_bindir}/ocamlyacc + +# symlink to either .byte or .opt version %{_bindir}/ocamlc -%if %{native_compiler} -%{_bindir}/ocamlc.opt -%endif %{_bindir}/ocamlcp -%{_bindir}/ocamldebug %{_bindir}/ocamldep -%if %{native_compiler} -%{_bindir}/ocamldep.opt -%endif %{_bindir}/ocamllex -%if %{native_compiler} -%{_bindir}/ocamllex.opt -%endif %{_bindir}/ocamlmklib %{_bindir}/ocamlmktop %{_bindir}/ocamlobjinfo +%{_bindir}/ocamloptp +%{_bindir}/ocamlprof + +# bytecode versions +%{_bindir}/ocamlc.byte +%{_bindir}/ocamlcp.byte +%{_bindir}/ocamldep.byte +%{_bindir}/ocamllex.byte +%{_bindir}/ocamlmklib.byte +%{_bindir}/ocamlmktop.byte +%{_bindir}/ocamlobjinfo.byte +%{_bindir}/ocamloptp.byte +%{_bindir}/ocamlprof.byte + +%if %{native_compiler} +# native code versions +%{_bindir}/ocamlc.opt +%{_bindir}/ocamlcp.opt +%{_bindir}/ocamldep.opt +%{_bindir}/ocamllex.opt +%{_bindir}/ocamlmklib.opt +%{_bindir}/ocamlmktop.opt +%{_bindir}/ocamlobjinfo.opt +%{_bindir}/ocamloptp.opt +%{_bindir}/ocamlprof.opt +%endif + %if %{native_compiler} %{_bindir}/ocamlopt +%{_bindir}/ocamlopt.byte %{_bindir}/ocamlopt.opt %endif -%{_bindir}/ocamloptp -#%{_bindir}/ocamlplugininfo -%{_bindir}/ocamlprof -%{_bindir}/ocamlyacc + #%{_libdir}/ocaml/addlabels #%{_libdir}/ocaml/scrapelabels %{_libdir}/ocaml/camlheader @@ -438,6 +393,7 @@ fi %{_libdir}/ocaml/*.cmxa %{_libdir}/ocaml/*.cmx %{_libdir}/ocaml/*.o +%{_libdir}/ocaml/libasmrun_shared.so %endif %{_libdir}/ocaml/*.mli %{_libdir}/ocaml/libcamlrun_shared.so @@ -450,12 +406,11 @@ fi %{_libdir}/ocaml/threads/*.cmx %endif %{_libdir}/ocaml/caml -%{_libdir}/ocaml/ocamlbuild %exclude %{_libdir}/ocaml/graphicsX11.mli %files runtime -%doc README LICENSE Changes +%doc README.adoc LICENSE Changes %{_bindir}/ocamlrun %dir %{_libdir}/ocaml %{_libdir}/ocaml/VERSION @@ -471,9 +426,6 @@ fi %{_libdir}/ocaml/threads/*.cma %{_libdir}/ocaml/fedora-ocaml-release %exclude %{_libdir}/ocaml/graphicsX11.cmi -%exclude %{_libdir}/ocaml/stublibs/dlllabltk.so -#%exclude %{_libdir}/ocaml/stublibs/dlltkanim.so -%{macros_dir}/macros.ocaml-srpm %files source @@ -487,74 +439,6 @@ fi %{_libdir}/ocaml/graphicsX11.mli -%files labltk -%doc LICENSE -%{_bindir}/labltk -%dir %{_libdir}/ocaml/labltk -%{_libdir}/ocaml/labltk/*.cmi -%{_libdir}/ocaml/labltk/*.cma -%{_libdir}/ocaml/labltk/*.cmo -%{_libdir}/ocaml/stublibs/dlllabltk.so -#%{_libdir}/ocaml/stublibs/dlltkanim.so - - -%files labltk-devel -%doc LICENSE -%doc otherlibs/labltk/examples_labltk -%doc otherlibs/labltk/examples_camltk -%{_bindir}/ocamlbrowser -%{_libdir}/ocaml/labltk/labltktop -%{_libdir}/ocaml/labltk/pp -%{_libdir}/ocaml/labltk/tkcompiler -%{_libdir}/ocaml/labltk/*.a -%if %{native_compiler} -%{_libdir}/ocaml/labltk/*.cmxa -%{_libdir}/ocaml/labltk/*.cmx -%{_libdir}/ocaml/labltk/*.o -%endif -%{_libdir}/ocaml/labltk/*.mli - - -%files camlp4 -%doc LICENSE -%dir %{_libdir}/ocaml/camlp4 -%{_libdir}/ocaml/camlp4/*.cmi -%{_libdir}/ocaml/camlp4/*.cma -%{_libdir}/ocaml/camlp4/*.cmo -%dir %{_libdir}/ocaml/camlp4/Camlp4Filters -%{_libdir}/ocaml/camlp4/Camlp4Filters/*.cmi -%{_libdir}/ocaml/camlp4/Camlp4Filters/*.cmo -%dir %{_libdir}/ocaml/camlp4/Camlp4Parsers -%{_libdir}/ocaml/camlp4/Camlp4Parsers/*.cmo -%{_libdir}/ocaml/camlp4/Camlp4Parsers/*.cmi -%dir %{_libdir}/ocaml/camlp4/Camlp4Printers -%{_libdir}/ocaml/camlp4/Camlp4Printers/*.cmi -%{_libdir}/ocaml/camlp4/Camlp4Printers/*.cmo -%dir %{_libdir}/ocaml/camlp4/Camlp4Top -%{_libdir}/ocaml/camlp4/Camlp4Top/*.cmi -%{_libdir}/ocaml/camlp4/Camlp4Top/*.cmo - - -%files camlp4-devel -%{_bindir}/camlp4* -%{_bindir}/mkcamlp4 -%if %{native_compiler} -%{_libdir}/ocaml/camlp4/*.a -%{_libdir}/ocaml/camlp4/*.cmxa -%{_libdir}/ocaml/camlp4/*.cmx -%{_libdir}/ocaml/camlp4/*.o -%{_libdir}/ocaml/camlp4/Camlp4Filters/*.cmx -%{_libdir}/ocaml/camlp4/Camlp4Filters/*.o -%{_libdir}/ocaml/camlp4/Camlp4Parsers/*.cmx -%{_libdir}/ocaml/camlp4/Camlp4Parsers/*.o -%{_libdir}/ocaml/camlp4/Camlp4Printers/*.cmx -%{_libdir}/ocaml/camlp4/Camlp4Printers/*.o -%{_libdir}/ocaml/camlp4/Camlp4Top/*.cmx -%{_libdir}/ocaml/camlp4/Camlp4Top/*.o -%endif -%{_mandir}/man1/* - - %files ocamldoc %doc LICENSE %doc ocamldoc/Changes.txt @@ -565,18 +449,22 @@ fi %files docs %doc refman.pdf htmlman %{_infodir}/* +%{_mandir}/man1/* %{_mandir}/man3/* +%ifnarch riscv64 %files emacs %doc emacs/README %{_datadir}/emacs/site-lisp/* %{_bindir}/ocamltags +%endif %files compiler-libs %doc LICENSE %dir %{_libdir}/ocaml/compiler-libs +%{_libdir}/ocaml/compiler-libs/*.mli %{_libdir}/ocaml/compiler-libs/*.cmi %{_libdir}/ocaml/compiler-libs/*.cmo %{_libdir}/ocaml/compiler-libs/*.cma @@ -589,9 +477,22 @@ fi %changelog +* Mon Sep 25 2017 Richard W.M. Jones - 4.05.0-6 +- Obsolete only ocaml-labltk (not ocaml-camlp4) + related: rhbz#1447988 + +* Fri Sep 22 2017 Richard W.M. Jones - 4.05.0-5 +- Obsolete ocaml-camlp4 and ocaml-labltk, removed in RHEL 7.5. + +* Fri Sep 15 2017 Richard W.M. Jones - 4.05.0-4 +- Rebase to 4.05.0 (same as Fedora Rawhide). +- Adds support for POWER, z/VM. +- Improves support for aarch64. + resolves: rhbz#1447988 + * Tue Jun 07 2016 Richard W.M. Jones - 4.01.0-22.7 - Fix buffer overflow and information leak CVE-2015-8869 - resolves: rhbz#1343100 + resolves: rhbz#1343081 * Tue Jul 07 2015 Richard W.M. Jones - 4.01.0-22.6 - ppc64le: Fix behaviour of Int64.max_int ÷ -1