From 2d717cb71a1bbbc9d39b922c44f44b551456fe9d Mon Sep 17 00:00:00 2001 From: David Allsopp Date: Sat, 27 Jul 2019 21:31:26 +0100 Subject: [PATCH 1/9] Add --disable-stdlib-manpages to configure --- .travis.yml | 2 +- Changes | 4 ++++ Makefile.config.in | 1 + configure | 17 +++++++++++++++++ configure.ac | 8 ++++++++ ocamldoc/Makefile | 2 +- 6 files changed, 32 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index d62371d758..8fbf24c6b5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,7 +22,7 @@ script: tools/ci/travis/travis-ci.sh matrix: include: - env: CI_KIND=build XARCH=x64 CONFIG_ARG=--enable-flambda OCAMLRUNPARAM=b,v=0 - - env: CI_KIND=build XARCH=i386 + - env: CI_KIND=build XARCH=i386 CONFIG_ARG=--disable-stdlib-manpages addons: apt: packages: diff --git a/Changes b/Changes index 7b82b1c922..0dee8b3ea8 100644 --- a/Changes +++ b/Changes @@ -221,6 +221,10 @@ Working version (Stephen Dolan, review by Gabriel Scherer, Sébastien Hinderer and Thomas Refis) +- #8835: new configure option --disable-stdlib-manpages to disable building + and installation of the library manpages. + (David Allsopp, review by Florian Angeletti and Gabriel Scherer) + - #8837: build manpages using ocamldoc.opt when available cuts the manpages build time from 14s to 4s (Gabriel Scherer, review by David Allsopp and Sébastien Hinderer, diff --git a/Makefile.config.in b/Makefile.config.in index d7ccb5be0f..51f5a1955b 100644 --- a/Makefile.config.in +++ b/Makefile.config.in @@ -234,6 +234,7 @@ MAX_TESTSUITE_DIR_RETRIES=@max_testsuite_dir_retries@ FLAT_FLOAT_ARRAY=@flat_float_array@ FUNCTION_SECTIONS=@function_sections@ AWK=@AWK@ +STDLIB_MANPAGES=@stdlib_manpages@ ### Native command to build ocamlrun.exe diff --git a/configure b/configure index c1613bd514..568b074ce6 100755 --- a/configure +++ b/configure @@ -691,6 +691,7 @@ build_os build_vendor build_cpu build +stdlib_manpages PACKLD flexlink_flags flexdll_chain @@ -848,6 +849,7 @@ enable_flambda enable_flambda_invariants with_target_bindir enable_reserved_header_bits +enable_stdlib_manpages enable_force_safe_string enable_flat_float_array enable_function_sections @@ -1523,6 +1525,8 @@ Optional Features: --enable-reserved-header-bits=BITS reserve BITS (between 0 and 31) bits in block headers for profiling info + --disable-stdlib-manpages + do not build or install the library man pages --disable-force-safe-string do not force strings to be safe --disable-flat-float-array @@ -2829,6 +2833,7 @@ VERSION=4.10.0+dev0-2019-04-23 + ## Generated files @@ -3155,6 +3160,12 @@ esac fi +# Check whether --enable-stdlib-manpages was given. +if test "${enable_stdlib_manpages+set}" = set; then : + enableval=$enable_stdlib_manpages; +fi + + # There are two configure-time string safety options, @@ -16766,6 +16777,12 @@ case $host in #( ;; esac +if test x"$enable_stdlib_manpages" != "xno"; then : + stdlib_manpages=manpages +else + stdlib_manpages= +fi + cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure diff --git a/configure.ac b/configure.ac index 0934a91f78..174eb62584 100644 --- a/configure.ac +++ b/configure.ac @@ -164,6 +164,7 @@ AC_SUBST([default_safe_string]) AC_SUBST([flexdll_chain]) AC_SUBST([flexlink_flags]) AC_SUBST([PACKLD]) +AC_SUBST([stdlib_manpages]) ## Generated files @@ -329,6 +330,10 @@ AC_ARG_ENABLE([reserved-header-bits], profinfo_width="$enable_reserved_header_bits"], [AC_MSG_ERROR([invalid argument to --enable-reserved-header-bits])])]) +AC_ARG_ENABLE([stdlib-manpages], + [AS_HELP_STRING([--disable-stdlib-manpages], + [do not build or install the library man pages])]) + AC_ARG_VAR([WINDOWS_UNICODE_MODE], [how to handle Unicode under Windows: ansi, compatible]) @@ -1782,4 +1787,7 @@ AS_CASE([$host], AC_DEFINE([HAS_IPV6]) AC_DEFINE([HAS_NICE])]) +AS_IF([test x"$enable_stdlib_manpages" != "xno"], + [stdlib_manpages=manpages],[stdlib_manpages=]) + AC_OUTPUT diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 8c29b42af4..7eca433eef 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -183,7 +183,7 @@ LIBCMIFILES = $(LIBCMOFILES:.cmo=.cmi) .PHONY: all -all: lib exe generators +all: lib exe generators $(STDLIB_MANPAGES) .PHONY: exe exe: $(OCAMLDOC) From 0912745754c25ee90483e4e08c111919ce94b392 Mon Sep 17 00:00:00 2001 From: David Allsopp Date: Fri, 27 Sep 2019 17:10:34 +0100 Subject: [PATCH 2/9] Make STDLIB_MANPAGES a boolean, not a target --- configure | 4 ++-- configure.ac | 2 +- ocamldoc/Makefile | 7 ++++++- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/configure b/configure index 568b074ce6..d996032b6a 100755 --- a/configure +++ b/configure @@ -16778,9 +16778,9 @@ case $host in #( esac if test x"$enable_stdlib_manpages" != "xno"; then : - stdlib_manpages=manpages + stdlib_manpages=true else - stdlib_manpages= + stdlib_manpages=false fi cat >confcache <<\_ACEOF diff --git a/configure.ac b/configure.ac index 174eb62584..a32b506a00 100644 --- a/configure.ac +++ b/configure.ac @@ -1788,6 +1788,6 @@ AS_CASE([$host], AC_DEFINE([HAS_NICE])]) AS_IF([test x"$enable_stdlib_manpages" != "xno"], - [stdlib_manpages=manpages],[stdlib_manpages=]) + [stdlib_manpages=true],[stdlib_manpages=false]) AC_OUTPUT diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 7eca433eef..97ad98e74c 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -181,9 +181,14 @@ LIBCMOFILES = $(CMOFILES) LIBCMXFILES = $(LIBCMOFILES:.cmo=.cmx) LIBCMIFILES = $(LIBCMOFILES:.cmo=.cmi) +ifeq "$(STDLIB_MANPAGES)" "true" +DOCS_TARGET = manpages +else +DOCS_TARGET = +endif .PHONY: all -all: lib exe generators $(STDLIB_MANPAGES) +all: lib exe generators $(DOCS_TARGET) .PHONY: exe exe: $(OCAMLDOC) From 454ee52984bc579d658b71b13e6fdce7c750c770 Mon Sep 17 00:00:00 2001 From: Damien Doligez Date: Fri, 4 Oct 2019 15:25:26 +0200 Subject: [PATCH 3/9] Fix #8789 --- Changes | 3 +++ parsing/pprintast.ml | 11 ++++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index 9988464a8a..ecf1e06813 100644 --- a/Changes +++ b/Changes @@ -85,6 +85,9 @@ Working version - #8992: share argument implementations between executables (Florian Angeletti, review by Gabriel Scherer) +- #9015: fix fatal error in pprint_ast (#8789) + (Damien Doligez, review by ...) + ### Code generation and optimizations: - #8990: amd64: Emit 32bit registers for Iconst_int when we can diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 06f8b18e43..09edf1aca0 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -1393,7 +1393,10 @@ and structure_item ctxt f x = (module_type ctxt) typ (module_expr ctxt) expr (item_attributes ctxt) pmb.pmb_attributes - | _ -> assert false + | pmb -> + pp f "@[@ and@ %s@ =@ %a@]%a" pmb.pmb_name.txt + (module_expr ctxt) pmb.pmb_expr + (item_attributes ctxt) pmb.pmb_attributes in begin match decls with | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> @@ -1403,6 +1406,12 @@ and structure_item ctxt f x = (module_expr ctxt) expr (item_attributes ctxt) pmb.pmb_attributes (fun f l2 -> List.iter (aux f) l2) l2 + | pmb :: l2 -> + pp f "@[@[module@ rec@ %s@ =@ %a@]%a@ %a@]" + pmb.pmb_name.txt + (module_expr ctxt) pmb.pmb_expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 | _ -> assert false end | Pstr_attribute a -> floating_attribute ctxt f a From 60f58174ba495becfab41b91bbbf5d49ffa1c262 Mon Sep 17 00:00:00 2001 From: Vincent Laviron Date: Fri, 4 Oct 2019 17:49:59 +0200 Subject: [PATCH 4/9] Split cmmgen into generic cmm helpers and clambda-specific transformations (#1963) --- .depend | 95 +- Changes | 3 + Makefile | 1 + asmcomp/asmgen.ml | 4 +- asmcomp/asmlink.ml | 27 +- asmcomp/cmm.mli | 5 +- asmcomp/cmm_helpers.ml | 2736 +++++++++++++++++++++++++++++++++++++ asmcomp/cmm_helpers.mli | 641 +++++++++ asmcomp/cmmgen.ml | 2754 ++------------------------------------ asmcomp/cmmgen.mli | 17 - asmcomp/cmmgen_state.ml | 5 + asmcomp/cmmgen_state.mli | 3 +- 12 files changed, 3595 insertions(+), 2696 deletions(-) create mode 100644 asmcomp/cmm_helpers.ml create mode 100644 asmcomp/cmm_helpers.mli diff --git a/.depend b/.depend index d2ecf3022b..e9509e019a 100644 --- a/.depend +++ b/.depend @@ -1964,6 +1964,7 @@ asmcomp/asmgen.cmo : \ asmcomp/comballoc.cmi \ asmcomp/coloring.cmi \ asmcomp/cmmgen.cmi \ + asmcomp/cmm_helpers.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ middle_end/clambda.cmi \ @@ -2003,6 +2004,7 @@ asmcomp/asmgen.cmx : \ asmcomp/comballoc.cmx \ asmcomp/coloring.cmx \ asmcomp/cmmgen.cmx \ + asmcomp/cmm_helpers.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ middle_end/clambda.cmx \ @@ -2054,7 +2056,7 @@ asmcomp/asmlink.cmo : \ utils/config.cmi \ middle_end/compilenv.cmi \ file_formats/cmx_format.cmi \ - asmcomp/cmmgen.cmi \ + asmcomp/cmm_helpers.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ utils/ccomp.cmi \ @@ -2072,7 +2074,7 @@ asmcomp/asmlink.cmx : \ utils/config.cmx \ middle_end/compilenv.cmx \ file_formats/cmx_format.cmi \ - asmcomp/cmmgen.cmx \ + asmcomp/cmm_helpers.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ utils/ccomp.cmx \ @@ -2177,13 +2179,11 @@ asmcomp/cmm.cmi : \ lambda/debuginfo.cmi \ middle_end/backend_var.cmi \ parsing/asttypes.cmi -asmcomp/cmmgen.cmo : \ - typing/types.cmi \ +asmcomp/cmm_helpers.cmo : \ utils/targetint.cmi \ lambda/switch.cmi \ asmcomp/strmatch.cmi \ asmcomp/proc.cmi \ - middle_end/printclambda_primitives.cmi \ typing/primitive.cmi \ utils/numbers.cmi \ utils/misc.cmi \ @@ -2201,15 +2201,12 @@ asmcomp/cmmgen.cmo : \ middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ - asmcomp/afl_instrument.cmi \ - asmcomp/cmmgen.cmi -asmcomp/cmmgen.cmx : \ - typing/types.cmx \ + asmcomp/cmm_helpers.cmi +asmcomp/cmm_helpers.cmx : \ utils/targetint.cmx \ lambda/switch.cmx \ asmcomp/strmatch.cmx \ asmcomp/proc.cmx \ - middle_end/printclambda_primitives.cmx \ typing/primitive.cmx \ utils/numbers.cmx \ utils/misc.cmx \ @@ -2227,19 +2224,71 @@ asmcomp/cmmgen.cmx : \ middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ + asmcomp/cmm_helpers.cmi +asmcomp/cmm_helpers.cmi : \ + utils/targetint.cmi \ + typing/primitive.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + file_formats/cmx_format.cmi \ + asmcomp/cmmgen_state.cmi \ + asmcomp/cmm.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/clambda.cmi \ + parsing/asttypes.cmi +asmcomp/cmmgen.cmo : \ + typing/types.cmi \ + middle_end/printclambda_primitives.cmi \ + typing/primitive.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + utils/config.cmi \ + middle_end/compilenv.cmi \ + asmcomp/cmmgen_state.cmi \ + asmcomp/cmm_helpers.cmi \ + asmcomp/cmm.cmi \ + utils/clflags.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ + parsing/asttypes.cmi \ + asmcomp/arch.cmo \ + asmcomp/afl_instrument.cmi \ + asmcomp/cmmgen.cmi +asmcomp/cmmgen.cmx : \ + typing/types.cmx \ + middle_end/printclambda_primitives.cmx \ + typing/primitive.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ + utils/config.cmx \ + middle_end/compilenv.cmx \ + asmcomp/cmmgen_state.cmx \ + asmcomp/cmm_helpers.cmx \ + asmcomp/cmm.cmx \ + utils/clflags.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ + parsing/asttypes.cmi \ + asmcomp/arch.cmx \ asmcomp/afl_instrument.cmx \ asmcomp/cmmgen.cmi asmcomp/cmmgen.cmi : \ - file_formats/cmx_format.cmi \ asmcomp/cmm.cmi \ middle_end/clambda.cmi asmcomp/cmmgen_state.cmo : \ utils/misc.cmi \ + middle_end/compilenv.cmi \ asmcomp/cmm.cmi \ middle_end/clambda.cmi \ asmcomp/cmmgen_state.cmi asmcomp/cmmgen_state.cmx : \ utils/misc.cmx \ + middle_end/compilenv.cmx \ asmcomp/cmm.cmx \ middle_end/clambda.cmx \ asmcomp/cmmgen_state.cmi @@ -5548,6 +5597,30 @@ asmcomp/debug/reg_with_debug_info.cmx : \ asmcomp/debug/reg_with_debug_info.cmi : \ asmcomp/reg.cmi \ middle_end/backend_var.cmi +driver/compdynlink.cmi : +driver/compdynlink_common.cmo : \ + driver/compdynlink_types.cmi \ + driver/compdynlink_platform_intf.cmi \ + driver/compdynlink_common.cmi +driver/compdynlink_common.cmx : \ + driver/compdynlink_types.cmx \ + driver/compdynlink_platform_intf.cmx \ + driver/compdynlink_common.cmi +driver/compdynlink_common.cmi : \ + driver/compdynlink_platform_intf.cmi +driver/compdynlink_platform_intf.cmo : \ + driver/compdynlink_types.cmi \ + driver/compdynlink_platform_intf.cmi +driver/compdynlink_platform_intf.cmx : \ + driver/compdynlink_types.cmx \ + driver/compdynlink_platform_intf.cmi +driver/compdynlink_platform_intf.cmi : \ + driver/compdynlink_types.cmi +driver/compdynlink_types.cmo : \ + driver/compdynlink_types.cmi +driver/compdynlink_types.cmx : \ + driver/compdynlink_types.cmi +driver/compdynlink_types.cmi : driver/compenv.cmo : \ utils/warnings.cmi \ utils/profile.cmi \ diff --git a/Changes b/Changes index 7d6a3d93f9..c28998e89c 100644 --- a/Changes +++ b/Changes @@ -30,6 +30,9 @@ Working version - #7927, #8527: Replace long tuples into records in typeclass.ml (Ulugbek Abdullaev, review by David Allsopp and Gabriel Scherer) +- #1963: split cmmgen into generic Cmm helpers and clambda transformations + (Vincent Laviron, review by Mark Shinwell) + - #1901: Fix lexing of character literals in comments (Pieter Goetschalckx, review by Damien Doligez) diff --git a/Makefile b/Makefile index f3080d1d31..c4c113a4c4 100644 --- a/Makefile +++ b/Makefile @@ -157,6 +157,7 @@ ASMCOMP=\ asmcomp/afl_instrument.cmo \ asmcomp/strmatch.cmo \ asmcomp/cmmgen_state.cmo \ + asmcomp/cmm_helpers.cmo \ asmcomp/cmmgen.cmo \ asmcomp/interval.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo \ diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index fed515f24d..1f209a5030 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -109,7 +109,7 @@ let compile_genfuns ~ppf_dump f = | (Cfunction {fun_name = name}) as ph when f name -> compile_phrase ~ppf_dump ph | _ -> ()) - (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) + (Cmm_helpers.generic_functions true [Compilenv.current_unit_infos ()]) let compile_unit asm_filename keep_asm obj_filename gen = let create_asm = keep_asm || not !Emitaux.binary_backend_available in @@ -146,7 +146,7 @@ let end_gen_implementation ?toplevel ~ppf_dump This is important if a module that uses such a symbol is later dynlinked. *) compile_phrase ~ppf_dump - (Cmmgen.reference_symbols + (Cmm_helpers.reference_symbols (List.filter_map (fun prim -> if not (Primitive.native_name_is_external prim) then None else Some (Primitive.native_name prim)) diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index d637e6d2ac..d087933960 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -230,24 +230,25 @@ let make_startup_file ~ppf_dump units_list ~crc_interfaces = Emit.begin_assembly (); let name_list = List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in - compile_phrase (Cmmgen.entry_point name_list); + compile_phrase (Cmm_helpers.entry_point name_list); let units = List.map (fun (info,_,_) -> info) units_list in - List.iter compile_phrase (Cmmgen.generic_functions false units); + List.iter compile_phrase (Cmm_helpers.generic_functions false units); Array.iteri - (fun i name -> compile_phrase (Cmmgen.predef_exception i name)) + (fun i name -> compile_phrase (Cmm_helpers.predef_exception i name)) Runtimedef.builtin_exceptions; - compile_phrase (Cmmgen.global_table name_list); + compile_phrase (Cmm_helpers.global_table name_list); let globals_map = make_globals_map units_list ~crc_interfaces in - compile_phrase (Cmmgen.globals_map globals_map); - compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); + compile_phrase (Cmm_helpers.globals_map globals_map); + compile_phrase(Cmm_helpers.data_segment_table ("_startup" :: name_list)); if !Clflags.function_sections then - compile_phrase(Cmmgen.code_segment_table("_hot" :: "_startup" :: name_list)) + compile_phrase + (Cmm_helpers.code_segment_table("_hot" :: "_startup" :: name_list)) else - compile_phrase(Cmmgen.code_segment_table("_startup" :: name_list)); + compile_phrase(Cmm_helpers.code_segment_table("_startup" :: name_list)); let all_names = "_startup" :: "_system" :: name_list in - compile_phrase (Cmmgen.frame_table all_names); + compile_phrase (Cmm_helpers.frame_table all_names); if Config.spacetime then begin - compile_phrase (Cmmgen.spacetime_shapes all_names); + compile_phrase (Cmm_helpers.spacetime_shapes all_names); end; if !Clflags.output_complete_object then force_linking_of_startup ~ppf_dump; @@ -259,10 +260,10 @@ let make_shared_startup_file ~ppf_dump units = Compilenv.reset "_shared_startup"; Emit.begin_assembly (); List.iter compile_phrase - (Cmmgen.generic_functions true (List.map fst units)); - compile_phrase (Cmmgen.plugin_header units); + (Cmm_helpers.generic_functions true (List.map fst units)); + compile_phrase (Cmm_helpers.plugin_header units); compile_phrase - (Cmmgen.global_table + (Cmm_helpers.global_table (List.map (fun (ui,_) -> ui.ui_symbol) units)); if !Clflags.output_complete_object then force_linking_of_startup ~ppf_dump; diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 4f0773e888..84c79a27f8 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -142,7 +142,10 @@ and operation = | Cfloatofint | Cintoffloat | Ccmpf of float_comparison | Craise of Lambda.raise_kind - | Ccheckbound + | Ccheckbound (* Takes two arguments : first the bound to check against, + then the index. + It results in a bounds error if the index is greater than + or equal to the bound. *) (** Every basic block should have a corresponding [Debuginfo.t] for its beginning. *) diff --git a/asmcomp/cmm_helpers.ml b/asmcomp/cmm_helpers.ml new file mode 100644 index 0000000000..0bec5d824b --- /dev/null +++ b/asmcomp/cmm_helpers.ml @@ -0,0 +1,2736 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-9-40-41-42-44-45"] + +module V = Backend_var +module VP = Backend_var.With_provenance +open Cmm +open Arch + +(* Local binding of complex expressions *) + +let bind name arg fn = + match arg with + Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ + | Cconst_pointer _ | Cconst_natpointer _ + | Cblockheader _ -> fn arg + | _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id)) + +let bind_load name arg fn = + match arg with + | Cop(Cload _, [Cvar _], _) -> fn arg + | _ -> bind name arg fn + +let bind_nonvar name arg fn = + match arg with + Cconst_int _ | Cconst_natint _ | Cconst_symbol _ + | Cconst_pointer _ | Cconst_natpointer _ + | Cblockheader _ -> fn arg + | _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id)) + +let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 + (* cf. runtime/caml/gc.h *) + +(* Block headers. Meaning of the tag field: see stdlib/obj.ml *) + +let floatarray_tag dbg = Cconst_int (Obj.double_array_tag, dbg) + +let block_header tag sz = + Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) + (Nativeint.of_int tag) +(* Static data corresponding to "value"s must be marked black in case we are + in no-naked-pointers mode. See [caml_darken] and the code below that emits + structured constants and static module definitions. *) +let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black +let white_closure_header sz = block_header Obj.closure_tag sz +let black_closure_header sz = black_block_header Obj.closure_tag sz +let infix_header ofs = block_header Obj.infix_tag ofs +let float_header = block_header Obj.double_tag (size_float / size_addr) +let floatarray_header len = + (* Zero-sized float arrays have tag zero for consistency with + [caml_alloc_float_array]. *) + assert (len >= 0); + if len = 0 then block_header 0 0 + else block_header Obj.double_array_tag (len * size_float / size_addr) +let string_header len = + block_header Obj.string_tag ((len + size_addr) / size_addr) +let boxedint32_header = block_header Obj.custom_tag 2 +let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr) +let boxedintnat_header = block_header Obj.custom_tag 2 +let caml_nativeint_ops = "caml_nativeint_ops" +let caml_int32_ops = "caml_int32_ops" +let caml_int64_ops = "caml_int64_ops" + + +let alloc_float_header dbg = Cblockheader (float_header, dbg) +let alloc_floatarray_header len dbg = Cblockheader (floatarray_header len, dbg) +let alloc_closure_header sz dbg = Cblockheader (white_closure_header sz, dbg) +let alloc_infix_header ofs dbg = Cblockheader (infix_header ofs, dbg) +let alloc_boxedint32_header dbg = Cblockheader (boxedint32_header, dbg) +let alloc_boxedint64_header dbg = Cblockheader (boxedint64_header, dbg) +let alloc_boxedintnat_header dbg = Cblockheader (boxedintnat_header, dbg) + +(* Integers *) + +let max_repr_int = max_int asr 1 +let min_repr_int = min_int asr 1 + +let int_const dbg n = + if n <= max_repr_int && n >= min_repr_int + then Cconst_int((n lsl 1) + 1, dbg) + else Cconst_natint + (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n, dbg) + +let natint_const_untagged dbg n = + if n > Nativeint.of_int max_int + || n < Nativeint.of_int min_int + then Cconst_natint (n,dbg) + else Cconst_int (Nativeint.to_int n, dbg) + +let cint_const n = + Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + +let targetint_const n = + Targetint.add (Targetint.shift_left (Targetint.of_int n) 1) + Targetint.one + +let add_no_overflow n x c dbg = + let d = n + x in + if d = 0 then c else Cop(Caddi, [c; Cconst_int (d, dbg)], dbg) + +let rec add_const c n dbg = + if n = 0 then c + else match c with + | Cconst_int (x, _) when Misc.no_overflow_add x n -> Cconst_int (x + n, dbg) + | Cop(Caddi, [Cconst_int (x, _); c], _) + when Misc.no_overflow_add n x -> + add_no_overflow n x c dbg + | Cop(Caddi, [c; Cconst_int (x, _)], _) + when Misc.no_overflow_add n x -> + add_no_overflow n x c dbg + | Cop(Csubi, [Cconst_int (x, _); c], _) when Misc.no_overflow_add n x -> + Cop(Csubi, [Cconst_int (n + x, dbg); c], dbg) + | Cop(Csubi, [c; Cconst_int (x, _)], _) when Misc.no_overflow_sub n x -> + add_const c (n - x) dbg + | c -> Cop(Caddi, [c; Cconst_int (n, dbg)], dbg) + +let incr_int c dbg = add_const c 1 dbg +let decr_int c dbg = add_const c (-1) dbg + +let rec add_int c1 c2 dbg = + match (c1, c2) with + | (Cconst_int (n, _), c) | (c, Cconst_int (n, _)) -> + add_const c n dbg + | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), c2) -> + add_const (add_int c1 c2 dbg) n1 dbg + | (c1, Cop(Caddi, [c2; Cconst_int (n2, _)], _)) -> + add_const (add_int c1 c2 dbg) n2 dbg + | (_, _) -> + Cop(Caddi, [c1; c2], dbg) + +let rec sub_int c1 c2 dbg = + match (c1, c2) with + | (c1, Cconst_int (n2, _)) when n2 <> min_int -> + add_const c1 (-n2) dbg + | (c1, Cop(Caddi, [c2; Cconst_int (n2, _)], _)) when n2 <> min_int -> + add_const (sub_int c1 c2 dbg) (-n2) dbg + | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), c2) -> + add_const (sub_int c1 c2 dbg) n1 dbg + | (c1, c2) -> + Cop(Csubi, [c1; c2], dbg) + +let rec lsl_int c1 c2 dbg = + match (c1, c2) with + | (Cop(Clsl, [c; Cconst_int (n1, _)], _), Cconst_int (n2, _)) + when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 -> + Cop(Clsl, [c; Cconst_int (n1 + n2, dbg)], dbg) + | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), Cconst_int (n2, _)) + when Misc.no_overflow_lsl n1 n2 -> + add_const (lsl_int c1 c2 dbg) (n1 lsl n2) dbg + | (_, _) -> + Cop(Clsl, [c1; c2], dbg) + +let is_power2 n = n = 1 lsl Misc.log2 n + +and mult_power2 c n dbg = lsl_int c (Cconst_int (Misc.log2 n, dbg)) dbg + +let rec mul_int c1 c2 dbg = + match (c1, c2) with + | (c, Cconst_int (0, _)) | (Cconst_int (0, _), c) -> + Csequence (c, Cconst_int (0, dbg)) + | (c, Cconst_int (1, _)) | (Cconst_int (1, _), c) -> + c + | (c, Cconst_int(-1, _)) | (Cconst_int(-1, _), c) -> + sub_int (Cconst_int (0, dbg)) c dbg + | (c, Cconst_int (n, _)) when is_power2 n -> mult_power2 c n dbg + | (Cconst_int (n, _), c) when is_power2 n -> mult_power2 c n dbg + | (Cop(Caddi, [c; Cconst_int (n, _)], _), Cconst_int (k, _)) | + (Cconst_int (k, _), Cop(Caddi, [c; Cconst_int (n, _)], _)) + when Misc.no_overflow_mul n k -> + add_const (mul_int c (Cconst_int (k, dbg)) dbg) (n * k) dbg + | (c1, c2) -> + Cop(Cmuli, [c1; c2], dbg) + + +let ignore_low_bit_int = function + Cop(Caddi, + [(Cop(Clsl, [_; Cconst_int (n, _)], _) as c); Cconst_int (1, _)], _) + when n > 0 + -> c + | Cop(Cor, [c; Cconst_int (1, _)], _) -> c + | c -> c + +let lsr_int c1 c2 dbg = + match c2 with + Cconst_int (0, _) -> + c1 + | Cconst_int (n, _) when n > 0 -> + Cop(Clsr, [ignore_low_bit_int c1; c2], dbg) + | _ -> + Cop(Clsr, [c1; c2], dbg) + +let asr_int c1 c2 dbg = + match c2 with + Cconst_int (0, _) -> + c1 + | Cconst_int (n, _) when n > 0 -> + Cop(Casr, [ignore_low_bit_int c1; c2], dbg) + | _ -> + Cop(Casr, [c1; c2], dbg) + +let tag_int i dbg = + match i with + Cconst_int (n, _) -> + int_const dbg n + | Cop(Casr, [c; Cconst_int (n, _)], _) when n > 0 -> + Cop(Cor, + [asr_int c (Cconst_int (n - 1, dbg)) dbg; Cconst_int (1, dbg)], + dbg) + | c -> + incr_int (lsl_int c (Cconst_int (1, dbg)) dbg) dbg + +let force_tag_int i dbg = + match i with + Cconst_int (n, _) -> + int_const dbg n + | Cop(Casr, [c; Cconst_int (n, _)], dbg') when n > 0 -> + Cop(Cor, [asr_int c (Cconst_int (n - 1, dbg)) dbg'; Cconst_int (1, dbg)], + dbg) + | c -> + Cop(Cor, [lsl_int c (Cconst_int (1, dbg)) dbg; Cconst_int (1, dbg)], dbg) + +let untag_int i dbg = + match i with + Cconst_int (n, _) -> Cconst_int(n asr 1, dbg) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], _) -> + c + | Cop(Cor, [Cop(Casr, [c; Cconst_int (n, _)], _); Cconst_int (1, _)], _) + when n > 0 && n < size_int * 8 -> + Cop(Casr, [c; Cconst_int (n+1, dbg)], dbg) + | Cop(Cor, [Cop(Clsr, [c; Cconst_int (n, _)], _); Cconst_int (1, _)], _) + when n > 0 && n < size_int * 8 -> + Cop(Clsr, [c; Cconst_int (n+1, dbg)], dbg) + | Cop(Cor, [c; Cconst_int (1, _)], _) -> + Cop(Casr, [c; Cconst_int (1, dbg)], dbg) + | c -> Cop(Casr, [c; Cconst_int (1, dbg)], dbg) + +let mk_if_then_else dbg cond ifso_dbg ifso ifnot_dbg ifnot = + match cond with + | Cconst_int (0, _) -> ifnot + | Cconst_int (1, _) -> ifso + | _ -> + Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) + +let mk_not dbg cmm = + match cmm with + | Cop(Caddi, + [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], dbg') -> + begin + match c with + | Cop(Ccmpi cmp, [c1; c2], dbg'') -> + tag_int + (Cop(Ccmpi (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg' + | Cop(Ccmpa cmp, [c1; c2], dbg'') -> + tag_int + (Cop(Ccmpa (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg' + | Cop(Ccmpf cmp, [c1; c2], dbg'') -> + tag_int + (Cop(Ccmpf (negate_float_comparison cmp), [c1; c2], dbg'')) dbg' + | _ -> + (* 0 -> 3, 1 -> 1 *) + Cop(Csubi, + [Cconst_int (3, dbg); Cop(Clsl, [c; Cconst_int (1, dbg)], dbg)], + dbg) + end + | Cconst_int (3, _) -> Cconst_int (1, dbg) + | Cconst_int (1, _) -> Cconst_int (3, dbg) + | c -> + (* 1 -> 3, 3 -> 1 *) + Cop(Csubi, [Cconst_int (4, dbg); c], dbg) + + +let create_loop body dbg = + let cont = Lambda.next_raise_count () in + let call_cont = Cexit (cont, []) in + let body = Csequence (body, call_cont) in + Ccatch (Recursive, [cont, [], body, dbg], call_cont) + +(* Turning integer divisions into multiply-high then shift. + The [division_parameters] function is used in module Emit for + those target platforms that support this optimization. *) + +(* Unsigned comparison between native integers. *) + +let ucompare x y = Nativeint.(compare (add x min_int) (add y min_int)) + +(* Unsigned division and modulus at type nativeint. + Algorithm: Hacker's Delight section 9.3 *) + +let udivmod n d = Nativeint.( + if d < 0n then + if ucompare n d < 0 then (0n, n) else (1n, sub n d) + else begin + let q = shift_left (div (shift_right_logical n 1) d) 1 in + let r = sub n (mul q d) in + if ucompare r d >= 0 then (succ q, sub r d) else (q, r) + end) + +(* Compute division parameters. + Algorithm: Hacker's Delight chapter 10, fig 10-1. *) + +let divimm_parameters d = Nativeint.( + assert (d > 0n); + let twopsm1 = min_int in (* 2^31 for 32-bit archs, 2^63 for 64-bit archs *) + let nc = sub (pred twopsm1) (snd (udivmod twopsm1 d)) in + let rec loop p (q1, r1) (q2, r2) = + let p = p + 1 in + let q1 = shift_left q1 1 and r1 = shift_left r1 1 in + let (q1, r1) = + if ucompare r1 nc >= 0 then (succ q1, sub r1 nc) else (q1, r1) in + let q2 = shift_left q2 1 and r2 = shift_left r2 1 in + let (q2, r2) = + if ucompare r2 d >= 0 then (succ q2, sub r2 d) else (q2, r2) in + let delta = sub d r2 in + if ucompare q1 delta < 0 || (q1 = delta && r1 = 0n) + then loop p (q1, r1) (q2, r2) + else (succ q2, p - size) + in loop (size - 1) (udivmod twopsm1 nc) (udivmod twopsm1 d)) + +(* The result [(m, p)] of [divimm_parameters d] satisfies the following + inequality: + + 2^(wordsize + p) < m * d <= 2^(wordsize + p) + 2^(p + 1) (i) + + from which it follows that + + floor(n / d) = floor(n * m / 2^(wordsize+p)) + if 0 <= n < 2^(wordsize-1) + ceil(n / d) = floor(n * m / 2^(wordsize+p)) + 1 + if -2^(wordsize-1) <= n < 0 + + The correctness condition (i) above can be checked by the code below. + It was exhaustively tested for values of d from 2 to 10^9 in the + wordsize = 64 case. + +let add2 (xh, xl) (yh, yl) = + let zl = add xl yl and zh = add xh yh in + ((if ucompare zl xl < 0 then succ zh else zh), zl) + +let shl2 (xh, xl) n = + assert (0 < n && n < size + size); + if n < size + then (logor (shift_left xh n) (shift_right_logical xl (size - n)), + shift_left xl n) + else (shift_left xl (n - size), 0n) + +let mul2 x y = + let halfsize = size / 2 in + let halfmask = pred (shift_left 1n halfsize) in + let xl = logand x halfmask and xh = shift_right_logical x halfsize in + let yl = logand y halfmask and yh = shift_right_logical y halfsize in + add2 (mul xh yh, 0n) + (add2 (shl2 (0n, mul xl yh) halfsize) + (add2 (shl2 (0n, mul xh yl) halfsize) + (0n, mul xl yl))) + +let ucompare2 (xh, xl) (yh, yl) = + let c = ucompare xh yh in if c = 0 then ucompare xl yl else c + +let validate d m p = + let md = mul2 m d in + let one2 = (0n, 1n) in + let twoszp = shl2 one2 (size + p) in + let twop1 = shl2 one2 (p + 1) in + ucompare2 twoszp md < 0 && ucompare2 md (add2 twoszp twop1) <= 0 +*) + +let raise_symbol dbg symb = + Cop(Craise Lambda.Raise_regular, [Cconst_symbol (symb, dbg)], dbg) + +let rec div_int c1 c2 is_safe dbg = + match (c1, c2) with + (c1, Cconst_int (0, _)) -> + Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") + | (c1, Cconst_int (1, _)) -> + c1 + | (Cconst_int (n1, _), Cconst_int (n2, _)) -> + Cconst_int (n1 / n2, dbg) + | (c1, Cconst_int (n, _)) when n <> min_int -> + let l = Misc.log2 n in + if n = 1 lsl l then + (* Algorithm: + t = shift-right-signed(c1, l - 1) + t = shift-right(t, W - l) + t = c1 + t + res = shift-right-signed(c1 + t, l) + *) + Cop(Casr, [bind "dividend" c1 (fun c1 -> + let t = asr_int c1 (Cconst_int (l - 1, dbg)) dbg in + let t = + lsr_int t (Cconst_int (Nativeint.size - l, dbg)) dbg + in + add_int c1 t dbg); + Cconst_int (l, dbg)], dbg) + else if n < 0 then + sub_int (Cconst_int (0, dbg)) + (div_int c1 (Cconst_int (-n, dbg)) is_safe dbg) + dbg + else begin + let (m, p) = divimm_parameters (Nativeint.of_int n) in + (* Algorithm: + t = multiply-high-signed(c1, m) + if m < 0, t = t + c1 + if p > 0, t = shift-right-signed(t, p) + res = t + sign-bit(c1) + *) + bind "dividend" c1 (fun c1 -> + let t = Cop(Cmulhi, [c1; Cconst_natint (m, dbg)], dbg) in + let t = if m < 0n then Cop(Caddi, [t; c1], dbg) else t in + let t = + if p > 0 then Cop(Casr, [t; Cconst_int (p, dbg)], dbg) else t + in + add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1, dbg)) dbg) dbg) + end + | (c1, c2) when !Clflags.unsafe || is_safe = Lambda.Unsafe -> + Cop(Cdivi, [c1; c2], dbg) + | (c1, c2) -> + bind "divisor" c2 (fun c2 -> + bind "dividend" c1 (fun c1 -> + Cifthenelse(c2, + dbg, + Cop(Cdivi, [c1; c2], dbg), + dbg, + raise_symbol dbg "caml_exn_Division_by_zero", + dbg))) + +let mod_int c1 c2 is_safe dbg = + match (c1, c2) with + (c1, Cconst_int (0, _)) -> + Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") + | (c1, Cconst_int ((1 | (-1)), _)) -> + Csequence(c1, Cconst_int (0, dbg)) + | (Cconst_int (n1, _), Cconst_int (n2, _)) -> + Cconst_int (n1 mod n2, dbg) + | (c1, (Cconst_int (n, _) as c2)) when n <> min_int -> + let l = Misc.log2 n in + if n = 1 lsl l then + (* Algorithm: + t = shift-right-signed(c1, l - 1) + t = shift-right(t, W - l) + t = c1 + t + t = bit-and(t, -n) + res = c1 - t + *) + bind "dividend" c1 (fun c1 -> + let t = asr_int c1 (Cconst_int (l - 1, dbg)) dbg in + let t = lsr_int t (Cconst_int (Nativeint.size - l, dbg)) dbg in + let t = add_int c1 t dbg in + let t = Cop(Cand, [t; Cconst_int (-n, dbg)], dbg) in + sub_int c1 t dbg) + else + bind "dividend" c1 (fun c1 -> + sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2 dbg) dbg) + | (c1, c2) when !Clflags.unsafe || is_safe = Lambda.Unsafe -> + (* Flambda already generates that test *) + Cop(Cmodi, [c1; c2], dbg) + | (c1, c2) -> + bind "divisor" c2 (fun c2 -> + bind "dividend" c1 (fun c1 -> + Cifthenelse(c2, + dbg, + Cop(Cmodi, [c1; c2], dbg), + dbg, + raise_symbol dbg "caml_exn_Division_by_zero", + dbg))) + +(* Division or modulo on boxed integers. The overflow case min_int / -1 + can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) + +let is_different_from x = function + Cconst_int (n, _) -> n <> x + | Cconst_natint (n, _) -> n <> Nativeint.of_int x + | _ -> false + +let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg = + bind "dividend" c1 (fun c1 -> + bind "divisor" c2 (fun c2 -> + let c = mkop c1 c2 is_safe dbg in + if Arch.division_crashes_on_overflow + && (size_int = 4 || bi <> Primitive.Pint32) + && not (is_different_from (-1) c2) + then + Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int (-1, dbg)], dbg), + dbg, c, + dbg, mkm1 c1 dbg, + dbg) + else + c)) + +let safe_div_bi is_safe = + safe_divmod_bi div_int is_safe + (fun c1 dbg -> Cop(Csubi, [Cconst_int (0, dbg); c1], dbg)) + +let safe_mod_bi is_safe = + safe_divmod_bi mod_int is_safe (fun _ dbg -> Cconst_int (0, dbg)) + +(* Bool *) + +let test_bool dbg cmm = + match cmm with + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], _) -> + c + | Cconst_int (n, dbg) -> + if n = 1 then + Cconst_int (0, dbg) + else + Cconst_int (1, dbg) + | c -> Cop(Ccmpi Cne, [c; Cconst_int (1, dbg)], dbg) + +(* Float *) + +let box_float dbg c = Cop(Calloc, [alloc_float_header dbg; c], dbg) + +let unbox_float dbg = + map_tail + (function + | Cop(Calloc, [Cblockheader (hdr, _); c], _) + when Nativeint.equal hdr float_header -> + c + | Cconst_symbol (s, _dbg) as cmm -> + begin match Cmmgen_state.structured_constant_of_sym s with + | Some (Uconst_float x) -> + Cconst_float (x, dbg) (* or keep _dbg? *) + | _ -> + Cop(Cload (Double_u, Immutable), [cmm], dbg) + end + | cmm -> Cop(Cload (Double_u, Immutable), [cmm], dbg) + ) + +(* Complex *) + +let box_complex dbg c_re c_im = + Cop(Calloc, [alloc_floatarray_header 2 dbg; c_re; c_im], dbg) + +let complex_re c dbg = Cop(Cload (Double_u, Immutable), [c], dbg) +let complex_im c dbg = Cop(Cload (Double_u, Immutable), + [Cop(Cadda, [c; Cconst_int (size_float, dbg)], dbg)], + dbg) + +(* Unit *) + +let return_unit dbg c = Csequence(c, Cconst_pointer (1, dbg)) + +let rec remove_unit = function + Cconst_pointer (1, _) -> Ctuple [] + | Csequence(c, Cconst_pointer (1, _)) -> c + | Csequence(c1, c2) -> + Csequence(c1, remove_unit c2) + | Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) -> + Cifthenelse(cond, + ifso_dbg, remove_unit ifso, + ifnot_dbg, + remove_unit ifnot, dbg) + | Cswitch(sel, index, cases, dbg) -> + Cswitch(sel, index, + Array.map (fun (case, dbg) -> remove_unit case, dbg) cases, + dbg) + | Ccatch(rec_flag, handlers, body) -> + let map_h (n, ids, handler, dbg) = (n, ids, remove_unit handler, dbg) in + Ccatch(rec_flag, List.map map_h handlers, remove_unit body) + | Ctrywith(body, exn, handler, dbg) -> + Ctrywith(remove_unit body, exn, remove_unit handler, dbg) + | Clet(id, c1, c2) -> + Clet(id, c1, remove_unit c2) + | Cop(Capply _mty, args, dbg) -> + Cop(Capply typ_void, args, dbg) + | Cop(Cextcall(proc, _mty, alloc, label_after), args, dbg) -> + Cop(Cextcall(proc, typ_void, alloc, label_after), args, dbg) + | Cexit (_,_) as c -> c + | Ctuple [] as c -> c + | c -> Csequence(c, Ctuple []) + +(* Access to block fields *) + +let field_address ptr n dbg = + if n = 0 + then ptr + else Cop(Cadda, [ptr; Cconst_int(n * size_addr, dbg)], dbg) + +let get_field_gen mut ptr n dbg = + Cop(Cload (Word_val, mut), [field_address ptr n dbg], dbg) + +let set_field ptr n newval init dbg = + Cop(Cstore (Word_val, init), [field_address ptr n dbg; newval], dbg) + +let non_profinfo_mask = + if Config.profinfo + then (1 lsl (64 - Config.profinfo_width)) - 1 + else 0 (* [non_profinfo_mask] is unused in this case *) + +let get_header ptr dbg = + (* We cannot deem this as [Immutable] due to the presence of [Obj.truncate] + and [Obj.set_tag]. *) + Cop(Cload (Word_int, Mutable), + [Cop(Cadda, [ptr; Cconst_int(-size_int, dbg)], dbg)], dbg) + +let get_header_without_profinfo ptr dbg = + if Config.profinfo then + Cop(Cand, [get_header ptr dbg; Cconst_int (non_profinfo_mask, dbg)], dbg) + else + get_header ptr dbg + +let tag_offset = + if big_endian then -1 else -size_int + +let get_tag ptr dbg = + if Proc.word_addressed then (* If byte loads are slow *) + Cop(Cand, [get_header ptr dbg; Cconst_int (255, dbg)], dbg) + else (* If byte loads are efficient *) + (* Same comment as [get_header] above *) + Cop(Cload (Byte_unsigned, Mutable), + [Cop(Cadda, [ptr; Cconst_int(tag_offset, dbg)], dbg)], dbg) + +let get_size ptr dbg = + Cop(Clsr, [get_header_without_profinfo ptr dbg; Cconst_int (10, dbg)], dbg) + +(* Array indexing *) + +let log2_size_addr = Misc.log2 size_addr +let log2_size_float = Misc.log2 size_float + +let wordsize_shift = 9 +let numfloat_shift = 9 + log2_size_float - log2_size_addr + +let is_addr_array_hdr hdr dbg = + Cop(Ccmpi Cne, + [Cop(Cand, [hdr; Cconst_int (255, dbg)], dbg); floatarray_tag dbg], + dbg) + +let is_addr_array_ptr ptr dbg = + Cop(Ccmpi Cne, [get_tag ptr dbg; floatarray_tag dbg], dbg) + +let addr_array_length_shifted hdr dbg = + Cop(Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg) +let float_array_length_shifted hdr dbg = + Cop(Clsr, [hdr; Cconst_int (numfloat_shift, dbg)], dbg) + +let lsl_const c n dbg = + if n = 0 then c + else Cop(Clsl, [c; Cconst_int (n, dbg)], dbg) + +(* Produces a pointer to the element of the array [ptr] on the position [ofs] + with the given element [log2size] log2 element size. [ofs] is given as a + tagged int expression. + The optional ?typ argument is the C-- type of the result. + By default, it is Addr, meaning we are constructing a derived pointer + into the heap. If we know the pointer is outside the heap + (this is the case for bigarray indexing), we give type Int instead. *) + +let array_indexing ?typ log2size ptr ofs dbg = + let add = + match typ with + | None | Some Addr -> Cadda + | Some Int -> Caddi + | _ -> assert false in + match ofs with + | Cconst_int (n, _) -> + let i = n asr 1 in + if i = 0 then ptr + else Cop(add, [ptr; Cconst_int(i lsl log2size, dbg)], dbg) + | Cop(Caddi, + [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], dbg') -> + Cop(add, [ptr; lsl_const c log2size dbg], dbg') + | Cop(Caddi, [c; Cconst_int (n, _)], dbg') when log2size = 0 -> + Cop(add, + [Cop(add, [ptr; untag_int c dbg], dbg); Cconst_int (n asr 1, dbg)], + dbg') + | Cop(Caddi, [c; Cconst_int (n, _)], _) -> + Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1) dbg], dbg); + Cconst_int((n-1) lsl (log2size - 1), dbg)], dbg) + | _ when log2size = 0 -> + Cop(add, [ptr; untag_int ofs dbg], dbg) + | _ -> + Cop(add, [Cop(add, [ptr; lsl_const ofs (log2size - 1) dbg], dbg); + Cconst_int((-1) lsl (log2size - 1), dbg)], dbg) + +let addr_array_ref arr ofs dbg = + Cop(Cload (Word_val, Mutable), + [array_indexing log2_size_addr arr ofs dbg], dbg) +let int_array_ref arr ofs dbg = + Cop(Cload (Word_int, Mutable), + [array_indexing log2_size_addr arr ofs dbg], dbg) +let unboxed_float_array_ref arr ofs dbg = + Cop(Cload (Double_u, Mutable), + [array_indexing log2_size_float arr ofs dbg], dbg) +let float_array_ref arr ofs dbg = + box_float dbg (unboxed_float_array_ref arr ofs dbg) + +let addr_array_set arr ofs newval dbg = + Cop(Cextcall("caml_modify", typ_void, false, None), + [array_indexing log2_size_addr arr ofs dbg; newval], dbg) +let addr_array_initialize arr ofs newval dbg = + Cop(Cextcall("caml_initialize", typ_void, false, None), + [array_indexing log2_size_addr arr ofs dbg; newval], dbg) +let int_array_set arr ofs newval dbg = + Cop(Cstore (Word_int, Lambda.Assignment), + [array_indexing log2_size_addr arr ofs dbg; newval], dbg) +let float_array_set arr ofs newval dbg = + Cop(Cstore (Double_u, Lambda.Assignment), + [array_indexing log2_size_float arr ofs dbg; newval], dbg) + +(* String length *) + +(* Length of string block *) + +let string_length exp dbg = + bind "str" exp (fun str -> + let tmp_var = V.create_local "tmp" in + Clet(VP.create tmp_var, + Cop(Csubi, + [Cop(Clsl, + [get_size str dbg; + Cconst_int (log2_size_addr, dbg)], + dbg); + Cconst_int (1, dbg)], + dbg), + Cop(Csubi, + [Cvar tmp_var; + Cop(Cload (Byte_unsigned, Mutable), + [Cop(Cadda, [str; Cvar tmp_var], dbg)], dbg)], dbg))) + +let bigstring_length ba dbg = + Cop(Cload (Word_int, Mutable), [field_address ba 5 dbg], dbg) + +(* Message sending *) + +let lookup_tag obj tag dbg = + bind "tag" tag (fun tag -> + Cop(Cextcall("caml_get_public_method", typ_val, false, None), + [obj; tag], + dbg)) + +let lookup_label obj lab dbg = + bind "lab" lab (fun lab -> + let table = Cop (Cload (Word_val, Mutable), [obj], dbg) in + addr_array_ref table lab dbg) + +let call_cached_method obj tag cache pos args dbg = + let arity = List.length args in + let cache = array_indexing log2_size_addr cache pos dbg in + Compilenv.need_send_fun arity; + Cop(Capply typ_val, + Cconst_symbol("caml_send" ^ Int.to_string arity, dbg) :: + obj :: tag :: cache :: args, + dbg) + +(* Allocation *) + +let make_alloc_generic set_fn dbg tag wordsize args = + if wordsize <= Config.max_young_wosize then + Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg) + else begin + let id = V.create_local "*alloc*" in + let rec fill_fields idx = function + [] -> Cvar id + | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int (idx, dbg)) e1 dbg, + fill_fields (idx + 2) el) in + Clet(VP.create id, + Cop(Cextcall("caml_alloc", typ_val, true, None), + [Cconst_int (wordsize, dbg); Cconst_int (tag, dbg)], dbg), + fill_fields 1 args) + end + +let make_alloc dbg tag args = + let addr_array_init arr ofs newval dbg = + Cop(Cextcall("caml_initialize", typ_void, false, None), + [array_indexing log2_size_addr arr ofs dbg; newval], dbg) + in + make_alloc_generic addr_array_init dbg tag (List.length args) args + +let make_float_alloc dbg tag args = + make_alloc_generic float_array_set dbg tag + (List.length args * size_float / size_addr) args + +(* Bounds checking *) + +let make_checkbound dbg = function + | [Cop(Clsr, [a1; Cconst_int (n, _)], _); Cconst_int (m, _)] + when (m lsl n) > n -> + Cop(Ccheckbound, [a1; Cconst_int(m lsl n + 1 lsl n - 1, dbg)], dbg) + | args -> + Cop(Ccheckbound, args, dbg) + +(* Record application and currying functions *) + +let apply_function_sym n = + Compilenv.need_apply_fun n; "caml_apply" ^ Int.to_string n +let curry_function_sym n = + Compilenv.need_curry_fun n; + if n >= 0 + then "caml_curry" ^ Int.to_string n + else "caml_tuplify" ^ Int.to_string (-n) + +(* Big arrays *) + +let bigarray_elt_size : Lambda.bigarray_kind -> int = function + Pbigarray_unknown -> assert false + | Pbigarray_float32 -> 4 + | Pbigarray_float64 -> 8 + | Pbigarray_sint8 -> 1 + | Pbigarray_uint8 -> 1 + | Pbigarray_sint16 -> 2 + | Pbigarray_uint16 -> 2 + | Pbigarray_int32 -> 4 + | Pbigarray_int64 -> 8 + | Pbigarray_caml_int -> size_int + | Pbigarray_native_int -> size_int + | Pbigarray_complex32 -> 8 + | Pbigarray_complex64 -> 16 + +(* Produces a pointer to the element of the bigarray [b] on the position + [args]. [args] is given as a list of tagged int expressions, one per array + dimension. *) +let bigarray_indexing unsafe elt_kind layout b args dbg = + let check_ba_bound bound idx v = + Csequence(make_checkbound dbg [bound;idx], v) in + (* Validates the given multidimensional offset against the array bounds and + transforms it into a one dimensional offset. The offsets are expressions + evaluating to tagged int. *) + let rec ba_indexing dim_ofs delta_ofs = function + [] -> assert false + | [arg] -> + if unsafe then arg + else + bind "idx" arg (fun idx -> + (* Load the untagged int bound for the given dimension *) + let bound = + Cop(Cload (Word_int, Mutable), + [field_address b dim_ofs dbg], dbg) + in + let idxn = untag_int idx dbg in + check_ba_bound bound idxn idx) + | arg1 :: argl -> + (* The remainder of the list is transformed into a one dimensional offset + *) + let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in + (* Load the untagged int bound for the given dimension *) + let bound = + Cop(Cload (Word_int, Mutable), + [field_address b dim_ofs dbg], dbg) + in + if unsafe then add_int (mul_int (decr_int rem dbg) bound dbg) arg1 dbg + else + bind "idx" arg1 (fun idx -> + bind "bound" bound (fun bound -> + let idxn = untag_int idx dbg in + (* [offset = rem * (tag_int bound) + idx] *) + let offset = + add_int (mul_int (decr_int rem dbg) bound dbg) idx dbg + in + check_ba_bound bound idxn offset)) in + (* The offset as an expression evaluating to int *) + let offset = + match (layout : Lambda.bigarray_layout) with + Pbigarray_unknown_layout -> + assert false + | Pbigarray_c_layout -> + ba_indexing (4 + List.length args) (-1) (List.rev args) + | Pbigarray_fortran_layout -> + ba_indexing 5 1 + (List.map (fun idx -> sub_int idx (Cconst_int (2, dbg)) dbg) args) + and elt_size = + bigarray_elt_size elt_kind in + (* [array_indexing] can simplify the given expressions *) + array_indexing ~typ:Addr (Misc.log2 elt_size) + (Cop(Cload (Word_int, Mutable), + [field_address b 1 dbg], dbg)) offset dbg + +let bigarray_word_kind : Lambda.bigarray_kind -> memory_chunk = function + Pbigarray_unknown -> assert false + | Pbigarray_float32 -> Single + | Pbigarray_float64 -> Double + | Pbigarray_sint8 -> Byte_signed + | Pbigarray_uint8 -> Byte_unsigned + | Pbigarray_sint16 -> Sixteen_signed + | Pbigarray_uint16 -> Sixteen_unsigned + | Pbigarray_int32 -> Thirtytwo_signed + | Pbigarray_int64 -> Word_int + | Pbigarray_caml_int -> Word_int + | Pbigarray_native_int -> Word_int + | Pbigarray_complex32 -> Single + | Pbigarray_complex64 -> Double + +let bigarray_get unsafe elt_kind layout b args dbg = + bind "ba" b (fun b -> + match (elt_kind : Lambda.bigarray_kind) with + Pbigarray_complex32 | Pbigarray_complex64 -> + let kind = bigarray_word_kind elt_kind in + let sz = bigarray_elt_size elt_kind / 2 in + bind "addr" + (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> + bind "reval" + (Cop(Cload (kind, Mutable), [addr], dbg)) (fun reval -> + bind "imval" + (Cop(Cload (kind, Mutable), + [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg)], dbg)) + (fun imval -> box_complex dbg reval imval))) + | _ -> + Cop(Cload (bigarray_word_kind elt_kind, Mutable), + [bigarray_indexing unsafe elt_kind layout b args dbg], + dbg)) + +let bigarray_set unsafe elt_kind layout b args newval dbg = + bind "ba" b (fun b -> + match (elt_kind : Lambda.bigarray_kind) with + Pbigarray_complex32 | Pbigarray_complex64 -> + let kind = bigarray_word_kind elt_kind in + let sz = bigarray_elt_size elt_kind / 2 in + bind "newval" newval (fun newv -> + bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) + (fun addr -> + Csequence( + Cop(Cstore (kind, Assignment), [addr; complex_re newv dbg], dbg), + Cop(Cstore (kind, Assignment), + [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg); + complex_im newv dbg], + dbg)))) + | _ -> + Cop(Cstore (bigarray_word_kind elt_kind, Assignment), + [bigarray_indexing unsafe elt_kind layout b args dbg; newval], + dbg)) + +(* Boxed integers *) + +let operations_boxed_int (bi : Primitive.boxed_integer) = + match bi with + Pnativeint -> caml_nativeint_ops + | Pint32 -> caml_int32_ops + | Pint64 -> caml_int64_ops + +let alloc_header_boxed_int (bi : Primitive.boxed_integer) = + match bi with + Pnativeint -> alloc_boxedintnat_header + | Pint32 -> alloc_boxedint32_header + | Pint64 -> alloc_boxedint64_header + +let box_int_gen dbg (bi : Primitive.boxed_integer) arg = + let arg' = + if bi = Primitive.Pint32 && size_int = 8 && big_endian + then Cop(Clsl, [arg; Cconst_int (32, dbg)], dbg) + else arg + in + Cop(Calloc, [alloc_header_boxed_int bi dbg; + Cconst_symbol(operations_boxed_int bi, dbg); + arg'], dbg) + +let split_int64_for_32bit_target arg dbg = + bind "split_int64" arg (fun arg -> + let first = Cop (Cadda, [Cconst_int (size_int, dbg); arg], dbg) in + let second = Cop (Cadda, [Cconst_int (2 * size_int, dbg); arg], dbg) in + Ctuple [Cop (Cload (Thirtytwo_unsigned, Mutable), [first], dbg); + Cop (Cload (Thirtytwo_unsigned, Mutable), [second], dbg)]) + +let alloc_matches_boxed_int bi ~hdr ~ops = + match (bi : Primitive.boxed_integer), hdr, ops with + | Pnativeint, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) -> + Nativeint.equal hdr boxedintnat_header + && String.equal sym caml_nativeint_ops + | Pint32, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) -> + Nativeint.equal hdr boxedint32_header + && String.equal sym caml_int32_ops + | Pint64, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) -> + Nativeint.equal hdr boxedint64_header + && String.equal sym caml_int64_ops + | (Pnativeint | Pint32 | Pint64), _, _ -> false + +let unbox_int dbg bi = + let default arg = + if size_int = 4 && bi = Primitive.Pint64 then + split_int64_for_32bit_target arg dbg + else + Cop( + Cload((if bi = Primitive.Pint32 then Thirtytwo_signed else Word_int), + Immutable), + [Cop(Cadda, [arg; Cconst_int (size_addr, dbg)], dbg)], dbg) + in + map_tail + (function + | Cop(Calloc, + [hdr; ops; + Cop(Clsl, [contents; Cconst_int (32, _)], dbg')], _dbg) + when bi = Primitive.Pint32 && size_int = 8 && big_endian + && alloc_matches_boxed_int bi ~hdr ~ops -> + (* Force sign-extension of low 32 bits *) + Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg'); + Cconst_int (32, dbg)], + dbg) + | Cop(Calloc, + [hdr; ops; contents], _dbg) + when bi = Primitive.Pint32 && size_int = 8 && not big_endian + && alloc_matches_boxed_int bi ~hdr ~ops -> + (* Force sign-extension of low 32 bits *) + Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg); + Cconst_int (32, dbg)], + dbg) + | Cop(Calloc, [hdr; ops; contents], _dbg) + when alloc_matches_boxed_int bi ~hdr ~ops -> + contents + | Cconst_symbol (s, _dbg) as cmm -> + begin match Cmmgen_state.structured_constant_of_sym s, bi with + | Some (Uconst_nativeint n), Primitive.Pnativeint -> + Cconst_natint (n, dbg) + | Some (Uconst_int32 n), Primitive.Pint32 -> + Cconst_natint (Nativeint.of_int32 n, dbg) + | Some (Uconst_int64 n), Primitive.Pint64 -> + if size_int = 8 then + Cconst_natint (Int64.to_nativeint n, dbg) + else + let low = Int64.to_nativeint n in + let high = + Int64.to_nativeint (Int64.shift_right_logical n 32) + in + if big_endian then + Ctuple [Cconst_natint (high, dbg); Cconst_natint (low, dbg)] + else + Ctuple [Cconst_natint (low, dbg); Cconst_natint (high, dbg)] + | _ -> + default cmm + end + | cmm -> + default cmm + ) + +let make_unsigned_int bi arg dbg = + if bi = Primitive.Pint32 && size_int = 8 + then Cop(Cand, [arg; Cconst_natint (0xFFFFFFFFn, dbg)], dbg) + else arg + +let unaligned_load_16 ptr idx dbg = + if Arch.allow_unaligned_access + then Cop(Cload (Sixteen_unsigned, Mutable), [add_int ptr idx dbg], dbg) + else + let cconst_int i = Cconst_int (i, dbg) in + let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in + let v2 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) in + let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in + Cop(Cor, [lsl_int b1 (cconst_int 8) dbg; b2], dbg) + +let unaligned_set_16 ptr idx newval dbg = + if Arch.allow_unaligned_access + then + Cop(Cstore (Sixteen_unsigned, Assignment), + [add_int ptr idx dbg; newval], dbg) + else + let cconst_int i = Cconst_int (i, dbg) in + let v1 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); + cconst_int 0xFF], dbg) + in + let v2 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in + let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in + Csequence( + Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], dbg)) + +let unaligned_load_32 ptr idx dbg = + if Arch.allow_unaligned_access + then Cop(Cload (Thirtytwo_unsigned, Mutable), [add_int ptr idx dbg], dbg) + else + let cconst_int i = Cconst_int (i, dbg) in + let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in + let v2 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) + in + let v3 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 2) dbg], dbg) + in + let v4 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 3) dbg], dbg) + in + let b1, b2, b3, b4 = + if Arch.big_endian + then v1, v2, v3, v4 + else v4, v3, v2, v1 in + Cop(Cor, + [Cop(Cor, [lsl_int b1 (cconst_int 24) dbg; + lsl_int b2 (cconst_int 16) dbg], dbg); + Cop(Cor, [lsl_int b3 (cconst_int 8) dbg; b4], dbg)], + dbg) + +let unaligned_set_32 ptr idx newval dbg = + if Arch.allow_unaligned_access + then + Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx dbg; newval], + dbg) + else + let cconst_int i = Cconst_int (i, dbg) in + let v1 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int 24], dbg); cconst_int 0xFF], dbg) + in + let v2 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int 16], dbg); cconst_int 0xFF], dbg) + in + let v3 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); cconst_int 0xFF], dbg) + in + let v4 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in + let b1, b2, b3, b4 = + if Arch.big_endian + then v1, v2, v3, v4 + else v4, v3, v2, v1 in + Csequence( + Csequence( + Cop(Cstore (Byte_unsigned, Assignment), + [add_int ptr idx dbg; b1], dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], + dbg)), + Csequence( + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3], + dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4], + dbg))) + +let unaligned_load_64 ptr idx dbg = + assert(size_int = 8); + if Arch.allow_unaligned_access + then Cop(Cload (Word_int, Mutable), [add_int ptr idx dbg], dbg) + else + let cconst_int i = Cconst_int (i, dbg) in + let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in + let v2 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) in + let v3 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 2) dbg], dbg) in + let v4 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 3) dbg], dbg) in + let v5 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 4) dbg], dbg) in + let v6 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 5) dbg], dbg) in + let v7 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 6) dbg], dbg) in + let v8 = Cop(Cload (Byte_unsigned, Mutable), + [add_int (add_int ptr idx dbg) (cconst_int 7) dbg], dbg) in + let b1, b2, b3, b4, b5, b6, b7, b8 = + if Arch.big_endian + then v1, v2, v3, v4, v5, v6, v7, v8 + else v8, v7, v6, v5, v4, v3, v2, v1 in + Cop(Cor, + [Cop(Cor, + [Cop(Cor, [lsl_int b1 (cconst_int (8*7)) dbg; + lsl_int b2 (cconst_int (8*6)) dbg], dbg); + Cop(Cor, [lsl_int b3 (cconst_int (8*5)) dbg; + lsl_int b4 (cconst_int (8*4)) dbg], dbg)], + dbg); + Cop(Cor, + [Cop(Cor, [lsl_int b5 (cconst_int (8*3)) dbg; + lsl_int b6 (cconst_int (8*2)) dbg], dbg); + Cop(Cor, [lsl_int b7 (cconst_int 8) dbg; + b8], dbg)], + dbg)], dbg) + +let unaligned_set_64 ptr idx newval dbg = + assert(size_int = 8); + if Arch.allow_unaligned_access + then Cop(Cstore (Word_int, Assignment), [add_int ptr idx dbg; newval], dbg) + else + let cconst_int i = Cconst_int (i, dbg) in + let v1 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*7)], dbg); cconst_int 0xFF], + dbg) + in + let v2 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*6)], dbg); cconst_int 0xFF], + dbg) + in + let v3 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*5)], dbg); cconst_int 0xFF], + dbg) + in + let v4 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*4)], dbg); cconst_int 0xFF], + dbg) + in + let v5 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*3)], dbg); cconst_int 0xFF], + dbg) + in + let v6 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*2)], dbg); cconst_int 0xFF], + dbg) + in + let v7 = + Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); cconst_int 0xFF], + dbg) + in + let v8 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in + let b1, b2, b3, b4, b5, b6, b7, b8 = + if Arch.big_endian + then v1, v2, v3, v4, v5, v6, v7, v8 + else v8, v7, v6, v5, v4, v3, v2, v1 in + Csequence( + Csequence( + Csequence( + Cop(Cstore (Byte_unsigned, Assignment), + [add_int ptr idx dbg; b1], + dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], + dbg)), + Csequence( + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3], + dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4], + dbg))), + Csequence( + Csequence( + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 4) dbg; b5], + dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 5) dbg; b6], + dbg)), + Csequence( + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 6) dbg; b7], + dbg), + Cop(Cstore (Byte_unsigned, Assignment), + [add_int (add_int ptr idx dbg) (cconst_int 7) dbg; b8], + dbg)))) + +let max_or_zero a dbg = + bind "size" a (fun a -> + (* equivalent to + Cifthenelse(Cop(Ccmpi Cle, [a; cconst_int 0]), cconst_int 0, a) + + if a is positive, sign is 0 hence sign_negation is full of 1 + so sign_negation&a = a + if a is negative, sign is full of 1 hence sign_negation is 0 + so sign_negation&a = 0 *) + let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1, dbg)], dbg) in + let sign_negation = Cop(Cxor, [sign; Cconst_int (-1, dbg)], dbg) in + Cop(Cand, [sign_negation; a], dbg)) + +let check_bound safety access_size dbg length a2 k = + match (safety : Lambda.is_safe) with + | Unsafe -> k + | Safe -> + let offset = + match (access_size : Clambda_primitives.memory_access_size) with + | Sixteen -> 1 + | Thirty_two -> 3 + | Sixty_four -> 7 + in + let a1 = + sub_int length (Cconst_int (offset, dbg)) dbg + in + Csequence(make_checkbound dbg [max_or_zero a1 dbg; a2], k) + +let unaligned_set size ptr idx newval dbg = + match (size : Clambda_primitives.memory_access_size) with + | Sixteen -> unaligned_set_16 ptr idx newval dbg + | Thirty_two -> unaligned_set_32 ptr idx newval dbg + | Sixty_four -> unaligned_set_64 ptr idx newval dbg + +let unaligned_load size ptr idx dbg = + match (size : Clambda_primitives.memory_access_size) with + | Sixteen -> unaligned_load_16 ptr idx dbg + | Thirty_two -> unaligned_load_32 ptr idx dbg + | Sixty_four -> unaligned_load_64 ptr idx dbg + +let box_sized size dbg exp = + match (size : Clambda_primitives.memory_access_size) with + | Sixteen -> tag_int exp dbg + | Thirty_two -> box_int_gen dbg Pint32 exp + | Sixty_four -> box_int_gen dbg Pint64 exp + +(* Simplification of some primitives into C calls *) + +let default_prim name = + Primitive.simple ~name ~arity:0(*ignored*) ~alloc:true + + +let int64_native_prim name arity ~alloc = + let u64 = Primitive.Unboxed_integer Primitive.Pint64 in + let rec make_args = function 0 -> [] | n -> u64 :: make_args (n - 1) in + Primitive.make ~name ~native_name:(name ^ "_native") + ~alloc + ~native_repr_args:(make_args arity) + ~native_repr_res:u64 + +let simplif_primitive_32bits : + Clambda_primitives.primitive -> Clambda_primitives.primitive = function + Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int") + | Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int") + | Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32") + | Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32") + | Pcvtbint(Pnativeint, Pint64) -> + Pccall (default_prim "caml_int64_of_nativeint") + | Pcvtbint(Pint64, Pnativeint) -> + Pccall (default_prim "caml_int64_to_nativeint") + | Pnegbint Pint64 -> Pccall (int64_native_prim "caml_int64_neg" 1 + ~alloc:false) + | Paddbint Pint64 -> Pccall (int64_native_prim "caml_int64_add" 2 + ~alloc:false) + | Psubbint Pint64 -> Pccall (int64_native_prim "caml_int64_sub" 2 + ~alloc:false) + | Pmulbint Pint64 -> Pccall (int64_native_prim "caml_int64_mul" 2 + ~alloc:false) + | Pdivbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_div" 2 + ~alloc:true) + | Pmodbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_mod" 2 + ~alloc:true) + | Pandbint Pint64 -> Pccall (int64_native_prim "caml_int64_and" 2 + ~alloc:false) + | Porbint Pint64 -> Pccall (int64_native_prim "caml_int64_or" 2 + ~alloc:false) + | Pxorbint Pint64 -> Pccall (int64_native_prim "caml_int64_xor" 2 + ~alloc:false) + | Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left") + | Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned") + | Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right") + | Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal") + | Pbintcomp(Pint64, Lambda.Cne) -> Pccall (default_prim "caml_notequal") + | Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan") + | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") + | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") + | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") + | Pbigarrayref(_unsafe, n, Pbigarray_int64, _layout) -> + Pccall (default_prim ("caml_ba_get_" ^ Int.to_string n)) + | Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) -> + Pccall (default_prim ("caml_ba_set_" ^ Int.to_string n)) + | Pstring_load(Sixty_four, _) -> Pccall (default_prim "caml_string_get64") + | Pbytes_load(Sixty_four, _) -> Pccall (default_prim "caml_bytes_get64") + | Pbytes_set(Sixty_four, _) -> Pccall (default_prim "caml_bytes_set64") + | Pbigstring_load(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_get64") + | Pbigstring_set(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_set64") + | Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap") + | p -> p + +let simplif_primitive p : Clambda_primitives.primitive = + match (p : Clambda_primitives.primitive) with + | Pduprecord _ -> + Pccall (default_prim "caml_obj_dup") + | Pbigarrayref(_unsafe, n, Pbigarray_unknown, _layout) -> + Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) + | Pbigarrayset(_unsafe, n, Pbigarray_unknown, _layout) -> + Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) + | Pbigarrayref(_unsafe, n, _kind, Pbigarray_unknown_layout) -> + Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) + | Pbigarrayset(_unsafe, n, _kind, Pbigarray_unknown_layout) -> + Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) + | p -> + if size_int = 8 then p else simplif_primitive_32bits p + +(* Build switchers both for constants and blocks *) + +let transl_isout h arg dbg = tag_int (Cop(Ccmpa Clt, [h ; arg], dbg)) dbg + +(* Build an actual switch (ie jump table) *) + +let make_switch arg cases actions dbg = + let extract_uconstant = + function + (* Constant integers loaded from a table should end in 1, + so that Cload never produces untagged integers *) + | Cconst_int (n, _), _dbg + | Cconst_pointer (n, _), _dbg when (n land 1) = 1 -> + Some (Cint (Nativeint.of_int n)) + | Cconst_natint (n, _), _dbg + | Cconst_natpointer (n, _), _dbg + when Nativeint.(to_int (logand n one) = 1) -> + Some (Cint n) + | Cconst_symbol (s,_), _dbg -> + Some (Csymbol_address s) + | _ -> None + in + let extract_affine ~cases ~const_actions = + let length = Array.length cases in + if length >= 2 + then begin + match const_actions.(cases.(0)), const_actions.(cases.(1)) with + | Cint v0, Cint v1 -> + let slope = Nativeint.sub v1 v0 in + let check i = function + | Cint v -> v = Nativeint.(add (mul (of_int i) slope) v0) + | _ -> false + in + if Misc.Stdlib.Array.for_alli + (fun i idx -> check i const_actions.(idx)) cases + then Some (v0, slope) + else None + | _, _ -> + None + end + else None + in + let make_table_lookup ~cases ~const_actions arg dbg = + let table = Compilenv.new_const_symbol () in + Cmmgen_state.add_constant table (Const_table (Local, + Array.to_list (Array.map (fun act -> + const_actions.(act)) cases))); + addr_array_ref (Cconst_symbol (table, dbg)) (tag_int arg dbg) dbg + in + let make_affine_computation ~offset ~slope arg dbg = + (* In case the resulting integers are an affine function of the index, we + don't emit a table, and just compute the result directly *) + add_int + (mul_int arg (natint_const_untagged dbg slope) dbg) + (natint_const_untagged dbg offset) + dbg + in + match Misc.Stdlib.Array.all_somes (Array.map extract_uconstant actions) with + | None -> + Cswitch (arg,cases,actions,dbg) + | Some const_actions -> + match extract_affine ~cases ~const_actions with + | Some (offset, slope) -> + make_affine_computation ~offset ~slope arg dbg + | None -> make_table_lookup ~cases ~const_actions arg dbg + +module SArgBlocks = +struct + type primitive = operation + + let eqint = Ccmpi Ceq + let neint = Ccmpi Cne + let leint = Ccmpi Cle + let ltint = Ccmpi Clt + let geint = Ccmpi Cge + let gtint = Ccmpi Cgt + + type act = expression + + (* CR mshinwell: GPR#2294 will fix the Debuginfo here *) + + let make_const i = Cconst_int (i, Debuginfo.none) + let make_prim p args = Cop (p,args, Debuginfo.none) + let make_offset arg n = add_const arg n Debuginfo.none + let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none) + let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none) + let make_if cond ifso ifnot = + Cifthenelse (cond, Debuginfo.none, ifso, Debuginfo.none, ifnot, + Debuginfo.none) + let make_switch loc arg cases actions = + let dbg = Debuginfo.from_location loc in + let actions = Array.map (fun expr -> expr, dbg) actions in + make_switch arg cases actions dbg + let bind arg body = bind "switcher" arg body + + let make_catch handler = match handler with + | Cexit (i,[]) -> i,fun e -> e + | _ -> + let dbg = Debuginfo.none in + let i = Lambda.next_raise_count () in +(* + Printf.eprintf "SHARE CMM: %i\n" i ; + Printcmm.expression Format.str_formatter handler ; + Printf.eprintf "%s\n" (Format.flush_str_formatter ()) ; +*) + i, + (fun body -> match body with + | Cexit (j,_) -> + if i=j then handler + else body + | _ -> ccatch (i,[],body,handler, dbg)) + + let make_exit i = Cexit (i,[]) + +end + +(* cmm store, as sharing as normally been detected in previous + phases, we only share exits *) +(* Some specific patterns can lead to switches where several cases + point to the same action, but this action is not an exit (see GPR#1370). + The addition of the index in the action array as context allows to + share them correctly without duplication. *) +module StoreExpForSwitch = + Switch.CtxStore + (struct + type t = expression + type key = int option * int + type context = int + let make_key index expr = + let continuation = + match expr with + | Cexit (i,[]) -> Some i + | _ -> None + in + Some (continuation, index) + let compare_key (cont, index) (cont', index') = + match cont, cont' with + | Some i, Some i' when i = i' -> 0 + | _, _ -> Stdlib.compare index index' + end) + +(* For string switches, we can use a generic store *) +module StoreExp = + Switch.Store + (struct + type t = expression + type key = int + let make_key = function + | Cexit (i,[]) -> Some i + | _ -> None + let compare_key = Stdlib.compare + end) + +module SwitcherBlocks = Switch.Make(SArgBlocks) + +(* Int switcher, arg in [low..high], + cases is list of individual cases, and is sorted by first component *) + +let transl_int_switch loc arg low high cases default = match cases with +| [] -> assert false +| _::_ -> + let store = StoreExp.mk_store () in + assert (store.Switch.act_store () default = 0) ; + let cases = + List.map + (fun (i,act) -> i,store.Switch.act_store () act) + cases in + let rec inters plow phigh pact = function + | [] -> + if phigh = high then [plow,phigh,pact] + else [(plow,phigh,pact); (phigh+1,high,0) ] + | (i,act)::rem -> + if i = phigh+1 then + if pact = act then + inters plow i pact rem + else + (plow,phigh,pact)::inters i i act rem + else (* insert default *) + if pact = 0 then + if act = 0 then + inters plow i 0 rem + else + (plow,i-1,pact):: + inters i i act rem + else (* pact <> 0 *) + (plow,phigh,pact):: + begin + if act = 0 then inters (phigh+1) i 0 rem + else (phigh+1,i-1,0)::inters i i act rem + end in + let inters = match cases with + | [] -> assert false + | (k0,act0)::rem -> + if k0 = low then inters k0 k0 act0 rem + else inters low (k0-1) 0 cases in + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + loc + (low,high) + a + (Array.of_list inters) store) + + +let transl_switch_clambda loc arg index cases = + let store = StoreExpForSwitch.mk_store () in + let index = + Array.map + (fun j -> store.Switch.act_store j cases.(j)) + index in + let n_index = Array.length index in + let inters = ref [] + and this_high = ref (n_index-1) + and this_low = ref (n_index-1) + and this_act = ref index.(n_index-1) in + for i = n_index-2 downto 0 do + let act = index.(i) in + if act = !this_act then + decr this_low + else begin + inters := (!this_low, !this_high, !this_act) :: !inters ; + this_high := i ; + this_low := i ; + this_act := act + end + done ; + inters := (0, !this_high, !this_act) :: !inters ; + match !inters with + | [_] -> cases.(0) + | inters -> + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + loc + (0,n_index-1) + a + (Array.of_list inters) store) + +let strmatch_compile = + let module S = + Strmatch.Make + (struct + let string_block_length ptr = get_size ptr Debuginfo.none + let transl_switch = transl_int_switch + end) in + S.compile + +let ptr_offset ptr offset dbg = + if offset = 0 + then ptr + else Cop(Caddv, [ptr; Cconst_int(offset * size_addr, dbg)], dbg) + +let direct_apply lbl args dbg = + Cop(Capply typ_val, Cconst_symbol (lbl, dbg) :: args, dbg) + +let generic_apply mut clos args dbg = + match args with + | [arg] -> + bind "fun" clos (fun clos -> + Cop(Capply typ_val, [get_field_gen mut clos 0 dbg; arg; clos], + dbg)) + | _ -> + let arity = List.length args in + let cargs = + Cconst_symbol(apply_function_sym arity, dbg) :: args @ [clos] + in + Cop(Capply typ_val, cargs, dbg) + +let send kind met obj args dbg = + let call_met obj args clos = + (* met is never a simple expression, so it never gets turned into an + Immutable load *) + generic_apply Asttypes.Mutable clos (obj :: args) dbg + in + bind "obj" obj (fun obj -> + match (kind : Lambda.meth_kind), args with + Self, _ -> + bind "met" (lookup_label obj met dbg) + (call_met obj args) + | Cached, cache :: pos :: args -> + call_cached_method obj met cache pos args dbg + | _ -> + bind "met" (lookup_tag obj met dbg) + (call_met obj args)) + +(* +CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) +{ + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { // no need to check the 1st time + mi = ((li+hi) >> 1) | 1; + if (tag < Field(meths,mi)) hi = mi-2; + else li = mi; + } + *cache = (li-3)*sizeof(value)+1; + return Field (meths, li-1); +} +*) + +let cache_public_method meths tag cache dbg = + let raise_num = Lambda.next_raise_count () in + let cconst_int i = Cconst_int (i, dbg) in + let li = V.create_local "*li*" and hi = V.create_local "*hi*" + and mi = V.create_local "*mi*" and tagged = V.create_local "*tagged*" in + Clet ( + VP.create li, cconst_int 3, + Clet ( + VP.create hi, Cop(Cload (Word_int, Mutable), [meths], dbg), + Csequence( + ccatch + (raise_num, [], + create_loop + (Clet( + VP.create mi, + Cop(Cor, + [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); cconst_int 1], + dbg); + cconst_int 1], + dbg), + Csequence( + Cifthenelse + (Cop (Ccmpi Clt, + [tag; + Cop(Cload (Word_int, Mutable), + [Cop(Cadda, + [meths; lsl_const (Cvar mi) log2_size_addr dbg], + dbg)], + dbg)], dbg), + dbg, Cassign(hi, Cop(Csubi, [Cvar mi; cconst_int 2], dbg)), + dbg, Cassign(li, Cvar mi), + dbg), + Cifthenelse + (Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg), + dbg, Cexit (raise_num, []), + dbg, Ctuple [], + dbg)))) + dbg, + Ctuple [], + dbg), + Clet ( + VP.create tagged, + Cop(Cadda, [lsl_const (Cvar li) log2_size_addr dbg; + cconst_int(1 - 3 * size_addr)], dbg), + Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg), + Cvar tagged))))) + +(* CR mshinwell: These will be filled in by later pull requests. *) +let placeholder_dbg () = Debuginfo.none +let placeholder_fun_dbg ~human_name:_ = Debuginfo.none + +(* Generate an application function: + (defun caml_applyN (a1 ... aN clos) + (if (= clos.arity N) + (app clos.direct a1 ... aN clos) + (let (clos1 (app clos.code a1 clos) + clos2 (app clos1.code a2 clos) + ... + closN-1 (app closN-2.code aN-1 closN-2)) + (app closN-1.code aN closN-1)))) +*) + +let apply_function_body arity = + let dbg = placeholder_dbg in + let arg = Array.make arity (V.create_local "arg") in + for i = 1 to arity - 1 do arg.(i) <- V.create_local "arg" done; + let clos = V.create_local "clos" in + let rec app_fun clos n = + if n = arity-1 then + Cop(Capply typ_val, + [get_field_gen Asttypes.Mutable (Cvar clos) 0 (dbg ()); + Cvar arg.(n); + Cvar clos], + dbg ()) + else begin + let newclos = V.create_local "clos" in + Clet(VP.create newclos, + Cop(Capply typ_val, + [get_field_gen Asttypes.Mutable (Cvar clos) 0 (dbg ()); + Cvar arg.(n); Cvar clos], dbg ()), + app_fun newclos (n+1)) + end in + let args = Array.to_list arg in + let all_args = args @ [clos] in + (args, clos, + if arity = 1 then app_fun clos 0 else + Cifthenelse( + Cop(Ccmpi Ceq, [get_field_gen Asttypes.Mutable (Cvar clos) 1 (dbg ()); + int_const (dbg ()) arity], dbg ()), + dbg (), + Cop(Capply typ_val, + get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()) + :: List.map (fun s -> Cvar s) all_args, + dbg ()), + dbg (), + app_fun clos 0, + dbg ())) + +let send_function arity = + let dbg = placeholder_dbg in + let cconst_int i = Cconst_int (i, dbg ()) in + let (args, clos', body) = apply_function_body (1+arity) in + let cache = V.create_local "cache" + and obj = List.hd args + and tag = V.create_local "tag" in + let clos = + let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in + let meths = V.create_local "meths" and cached = V.create_local "cached" in + let real = V.create_local "real" in + let mask = get_field_gen Asttypes.Mutable (Cvar meths) 1 (dbg ()) in + let cached_pos = Cvar cached in + let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg ()); + cconst_int(3*size_addr-1)], dbg ()) in + let tag' = Cop(Cload (Word_int, Mutable), [tag_pos], dbg ()) in + Clet ( + VP.create meths, Cop(Cload (Word_val, Mutable), [obj], dbg ()), + Clet ( + VP.create cached, + Cop(Cand, [Cop(Cload (Word_int, Mutable), [cache], dbg ()); mask], + dbg ()), + Clet ( + VP.create real, + Cifthenelse(Cop(Ccmpa Cne, [tag'; tag], dbg ()), + dbg (), + cache_public_method (Cvar meths) tag cache (dbg ()), + dbg (), + cached_pos, + dbg ()), + Cop(Cload (Word_val, Mutable), + [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths], dbg ()); + cconst_int(2*size_addr-1)], dbg ())], dbg ())))) + + in + let body = Clet(VP.create clos', clos, body) in + let cache = cache in + let fun_name = "caml_send" ^ Int.to_string arity in + let fun_args = + [obj, typ_val; tag, typ_int; cache, typ_val] + @ List.map (fun id -> (id, typ_val)) (List.tl args) in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in + Cfunction + {fun_name; + fun_args = List.map (fun (arg, ty) -> VP.create arg, ty) fun_args; + fun_body = body; + fun_codegen_options = []; + fun_dbg; + } + +let apply_function arity = + let (args, clos, body) = apply_function_body arity in + let all_args = args @ [clos] in + let fun_name = "caml_apply" ^ Int.to_string arity in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in + Cfunction + {fun_name; + fun_args = List.map (fun arg -> (VP.create arg, typ_val)) all_args; + fun_body = body; + fun_codegen_options = []; + fun_dbg; + } + +(* Generate tuplifying functions: + (defun caml_tuplifyN (arg clos) + (app clos.direct #0(arg) ... #N-1(arg) clos)) *) + +let tuplify_function arity = + let dbg = placeholder_dbg in + let arg = V.create_local "arg" in + let clos = V.create_local "clos" in + let rec access_components i = + if i >= arity + then [] + else get_field_gen Asttypes.Mutable (Cvar arg) i (dbg ()) + :: access_components(i+1) + in + let fun_name = "caml_tuplify" ^ Int.to_string arity in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in + Cfunction + {fun_name; + fun_args = [VP.create arg, typ_val; VP.create clos, typ_val]; + fun_body = + Cop(Capply typ_val, + get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()) + :: access_components 0 @ [Cvar clos], + (dbg ())); + fun_codegen_options = []; + fun_dbg; + } + +(* Generate currying functions: + (defun caml_curryN (arg clos) + (alloc HDR caml_curryN_1 caml_curry_N_1_app arg clos)) + (defun caml_curryN_1 (arg clos) + (alloc HDR caml_curryN_2 caml_curry_N_2_app arg clos)) + ... + (defun caml_curryN_N-1 (arg clos) + (let (closN-2 clos.vars[1] + closN-3 closN-2.vars[1] + ... + clos1 clos2.vars[1] + clos clos1.vars[1]) + (app clos.direct + clos1.vars[0] ... closN-2.vars[0] clos.vars[0] arg clos))) + + Special "shortcut" functions are also generated to handle the + case where a partially applied function is applied to all remaining + arguments in one go. For instance: + (defun caml_curry_N_1_app (arg2 ... argN clos) + (let clos' clos.vars[1] + (app clos'.direct clos.vars[0] arg2 ... argN clos'))) + + Those shortcuts may lead to a quadratic number of application + primitives being generated in the worst case, which resulted in + linking time blowup in practice (PR#5933), so we only generate and + use them when below a fixed arity 'max_arity_optimized'. +*) + +let max_arity_optimized = 15 +let final_curry_function arity = + let dbg = placeholder_dbg in + let last_arg = V.create_local "arg" in + let last_clos = V.create_local "clos" in + let rec curry_fun args clos n = + if n = 0 then + Cop(Capply typ_val, + get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()) :: + args @ [Cvar last_arg; Cvar clos], + dbg ()) + else + if n = arity - 1 || arity > max_arity_optimized then + begin + let newclos = V.create_local "clos" in + Clet(VP.create newclos, + get_field_gen Asttypes.Mutable (Cvar clos) 3 (dbg ()), + curry_fun (get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()) + :: args) + newclos (n-1)) + end else + begin + let newclos = V.create_local "clos" in + Clet(VP.create newclos, + get_field_gen Asttypes.Mutable (Cvar clos) 4 (dbg ()), + curry_fun + (get_field_gen Asttypes.Mutable (Cvar clos) 3 (dbg ()) :: args) + newclos (n-1)) + end in + let fun_name = + "caml_curry" ^ Int.to_string arity ^ "_" ^ Int.to_string (arity-1) + in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in + Cfunction + {fun_name; + fun_args = [VP.create last_arg, typ_val; VP.create last_clos, typ_val]; + fun_body = curry_fun [] last_clos (arity-1); + fun_codegen_options = []; + fun_dbg; + } + +let rec intermediate_curry_functions arity num = + let dbg = placeholder_dbg in + if num = arity - 1 then + [final_curry_function arity] + else begin + let name1 = "caml_curry" ^ Int.to_string arity in + let name2 = if num = 0 then name1 else name1 ^ "_" ^ Int.to_string num in + let arg = V.create_local "arg" and clos = V.create_local "clos" in + let fun_dbg = placeholder_fun_dbg ~human_name:name2 in + Cfunction + {fun_name = name2; + fun_args = [VP.create arg, typ_val; VP.create clos, typ_val]; + fun_body = + if arity - num > 2 && arity <= max_arity_optimized then + Cop(Calloc, + [alloc_closure_header 5 (dbg ()); + Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ()); + int_const (dbg ()) (arity - num - 1); + Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1) ^ "_app", + dbg ()); + Cvar arg; Cvar clos], + dbg ()) + else + Cop(Calloc, + [alloc_closure_header 4 (dbg ()); + Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ()); + int_const (dbg ()) 1; Cvar arg; Cvar clos], + dbg ()); + fun_codegen_options = []; + fun_dbg; + } + :: + (if arity <= max_arity_optimized && arity - num > 2 then + let rec iter i = + if i <= arity then + let arg = V.create_local (Printf.sprintf "arg%d" i) in + (arg, typ_val) :: iter (i+1) + else [] + in + let direct_args = iter (num+2) in + let rec iter i args clos = + if i = 0 then + Cop(Capply typ_val, + (get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ())) + :: args @ [Cvar clos], + dbg ()) + else + let newclos = V.create_local "clos" in + Clet(VP.create newclos, + get_field_gen Asttypes.Mutable (Cvar clos) 4 (dbg ()), + iter (i-1) + (get_field_gen Asttypes.Mutable (Cvar clos) 3 (dbg ()) + :: args) + newclos) + in + let fun_args = + List.map (fun (arg, ty) -> VP.create arg, ty) + (direct_args @ [clos, typ_val]) + in + let fun_name = name1 ^ "_" ^ Int.to_string (num+1) ^ "_app" in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in + let cf = + Cfunction + {fun_name; + fun_args; + fun_body = iter (num+1) + (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; + fun_codegen_options = []; + fun_dbg; + } + in + cf :: intermediate_curry_functions arity (num+1) + else + intermediate_curry_functions arity (num+1)) + end + +let curry_function arity = + assert(arity <> 0); + (* Functions with arity = 0 does not have a curry_function *) + if arity > 0 + then intermediate_curry_functions arity 0 + else [tuplify_function (-arity)] + +module Int = Numbers.Int + +let default_apply = Int.Set.add 2 (Int.Set.add 3 Int.Set.empty) + (* These apply funs are always present in the main program because + the run-time system needs them (cf. runtime/.S) . *) + +let generic_functions shared units = + let (apply,send,curry) = + List.fold_left + (fun (apply,send,curry) (ui : Cmx_format.unit_infos) -> + List.fold_right Int.Set.add ui.ui_apply_fun apply, + List.fold_right Int.Set.add ui.ui_send_fun send, + List.fold_right Int.Set.add ui.ui_curry_fun curry) + (Int.Set.empty,Int.Set.empty,Int.Set.empty) + units in + let apply = if shared then apply else Int.Set.union apply default_apply in + let accu = Int.Set.fold (fun n accu -> apply_function n :: accu) apply [] in + let accu = Int.Set.fold (fun n accu -> send_function n :: accu) send accu in + Int.Set.fold (fun n accu -> curry_function n @ accu) curry accu + +(* Primitives *) + +type unary_primitive = expression -> Debuginfo.t -> expression + +let floatfield n ptr dbg = + Cop(Cload (Double_u, Mutable), + [if n = 0 then ptr + else Cop(Cadda, [ptr; Cconst_int(n * size_float, dbg)], dbg)], + dbg) + +let int_as_pointer arg dbg = + Cop(Caddi, [arg; Cconst_int (-1, dbg)], dbg) + (* always a pointer outside the heap *) + +let raise_prim raise_kind arg dbg = + if !Clflags.debug then + Cop (Craise raise_kind, [arg], dbg) + else + Cop (Craise Lambda.Raise_notrace, [arg], dbg) + +let negint arg dbg = + Cop(Csubi, [Cconst_int (2, dbg); arg], dbg) + +(* [offsetint] moved down to reuse add_int_caml *) + +let offsetref n arg dbg = + return_unit dbg + (bind "ref" arg (fun arg -> + Cop(Cstore (Word_int, Assignment), + [arg; + add_const (Cop(Cload (Word_int, Mutable), [arg], dbg)) + (n lsl 1) dbg], + dbg))) + +let arraylength kind arg dbg = + let hdr = get_header_without_profinfo arg dbg in + match (kind : Lambda.array_kind) with + Pgenarray -> + let len = + if wordsize_shift = numfloat_shift then + Cop(Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg) + else + bind "header" hdr (fun hdr -> + Cifthenelse(is_addr_array_hdr hdr dbg, + dbg, + Cop(Clsr, + [hdr; Cconst_int (wordsize_shift, dbg)], dbg), + dbg, + Cop(Clsr, + [hdr; Cconst_int (numfloat_shift, dbg)], dbg), + dbg)) + in + Cop(Cor, [len; Cconst_int (1, dbg)], dbg) + | Paddrarray | Pintarray -> + Cop(Cor, [addr_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg) + | Pfloatarray -> + Cop(Cor, [float_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg) + +let bbswap bi arg dbg = + let prim = match (bi : Primitive.boxed_integer) with + | Pnativeint -> "nativeint" + | Pint32 -> "int32" + | Pint64 -> "int64" + in + Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim, + typ_int, false, None), + [arg], + dbg) + +let bswap16 arg dbg = + (Cop(Cextcall("caml_bswap16_direct", typ_int, false, None), + [arg], + dbg)) + +type binary_primitive = expression -> expression -> Debuginfo.t -> expression + +(* let pfield_computed = addr_array_ref *) + +(* Helper for compilation of initialization and assignment operations *) + +type assignment_kind = Caml_modify | Caml_initialize | Simple + +let assignment_kind + (ptr: Lambda.immediate_or_pointer) + (init: Lambda.initialization_or_assignment) = + match init, ptr with + | Assignment, Pointer -> Caml_modify + | Heap_initialization, Pointer -> Caml_initialize + | Assignment, Immediate + | Heap_initialization, Immediate + | Root_initialization, (Immediate | Pointer) -> Simple + +let setfield n ptr init arg1 arg2 dbg = + match assignment_kind ptr init with + | Caml_modify -> + return_unit dbg (Cop(Cextcall("caml_modify", typ_void, false, None), + [field_address arg1 n dbg; + arg2], + dbg)) + | Caml_initialize -> + return_unit dbg (Cop(Cextcall("caml_initialize", typ_void, false, None), + [field_address arg1 n dbg; + arg2], + dbg)) + | Simple -> + return_unit dbg (set_field arg1 n arg2 init dbg) + +let setfloatfield n init arg1 arg2 dbg = + return_unit dbg ( + Cop(Cstore (Double_u, init), + [if n = 0 then arg1 + else Cop(Cadda, [arg1; Cconst_int(n * size_float, dbg)], dbg); + arg2], dbg)) + +let add_int_caml arg1 arg2 dbg = + decr_int (add_int arg1 arg2 dbg) dbg + +(* Unary primitive delayed to reuse add_int_caml *) +let offsetint n arg dbg = + if Misc.no_overflow_lsl n 1 then + add_const arg (n lsl 1) dbg + else + add_int_caml arg (int_const dbg n) dbg + +let sub_int_caml arg1 arg2 dbg = + incr_int (sub_int arg1 arg2 dbg) dbg + +let mul_int_caml arg1 arg2 dbg = + (* decrementing the non-constant part helps when the multiplication is + followed by an addition; + for example, using this trick compiles (100 * a + 7) into + (+ ( * a 100) -85) + rather than + (+ ( * 200 (>>s a 1)) 15) + *) + match arg1, arg2 with + | Cconst_int _ as c1, c2 -> + incr_int (mul_int (untag_int c1 dbg) (decr_int c2 dbg) dbg) dbg + | c1, c2 -> + incr_int (mul_int (decr_int c1 dbg) (untag_int c2 dbg) dbg) dbg + +let div_int_caml is_safe arg1 arg2 dbg = + tag_int(div_int (untag_int arg1 dbg) + (untag_int arg2 dbg) is_safe dbg) dbg + +let mod_int_caml is_safe arg1 arg2 dbg = + tag_int(mod_int (untag_int arg1 dbg) + (untag_int arg2 dbg) is_safe dbg) dbg + +let and_int_caml arg1 arg2 dbg = + Cop(Cand, [arg1; arg2], dbg) + +let or_int_caml arg1 arg2 dbg = + Cop(Cor, [arg1; arg2], dbg) + +let xor_int_caml arg1 arg2 dbg = + Cop(Cor, [Cop(Cxor, [ignore_low_bit_int arg1; + ignore_low_bit_int arg2], dbg); + Cconst_int (1, dbg)], dbg) + +let lsl_int_caml arg1 arg2 dbg = + incr_int(lsl_int (decr_int arg1 dbg) + (untag_int arg2 dbg) dbg) dbg + +let lsr_int_caml arg1 arg2 dbg = + Cop(Cor, [lsr_int arg1 (untag_int arg2 dbg) dbg; + Cconst_int (1, dbg)], dbg) + +let asr_int_caml arg1 arg2 dbg = + Cop(Cor, [asr_int arg1 (untag_int arg2 dbg) dbg; + Cconst_int (1, dbg)], dbg) + +let int_comp_caml cmp arg1 arg2 dbg = + tag_int(Cop(Ccmpi cmp, + [arg1; arg2], dbg)) dbg + +let stringref_unsafe arg1 arg2 dbg = + tag_int(Cop(Cload (Byte_unsigned, Mutable), + [add_int arg1 (untag_int arg2 dbg) dbg], + dbg)) dbg + +let stringref_safe arg1 arg2 dbg = + tag_int + (bind "str" arg1 (fun str -> + bind "index" (untag_int arg2 dbg) (fun idx -> + Csequence( + make_checkbound dbg [string_length str dbg; idx], + Cop(Cload (Byte_unsigned, Mutable), + [add_int str idx dbg], dbg))))) dbg + +let string_load size unsafe arg1 arg2 dbg = + box_sized size dbg + (bind "str" arg1 (fun str -> + bind "index" (untag_int arg2 dbg) (fun idx -> + check_bound unsafe size dbg + (string_length str dbg) + idx (unaligned_load size str idx dbg)))) + +let bigstring_load size unsafe arg1 arg2 dbg = + box_sized size dbg + (bind "ba" arg1 (fun ba -> + bind "index" (untag_int arg2 dbg) (fun idx -> + bind "ba_data" + (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) + (fun ba_data -> + check_bound unsafe size dbg + (bigstring_length ba dbg) + idx + (unaligned_load size ba_data idx dbg))))) + +let arrayref_unsafe kind arg1 arg2 dbg = + match (kind : Lambda.array_kind) with + | Pgenarray -> + bind "arr" arg1 (fun arr -> + bind "index" arg2 (fun idx -> + Cifthenelse(is_addr_array_ptr arr dbg, + dbg, + addr_array_ref arr idx dbg, + dbg, + float_array_ref arr idx dbg, + dbg))) + | Paddrarray -> + addr_array_ref arg1 arg2 dbg + | Pintarray -> + (* CR mshinwell: for int/addr_array_ref move "dbg" to first arg *) + int_array_ref arg1 arg2 dbg + | Pfloatarray -> + float_array_ref arg1 arg2 dbg + +let arrayref_safe kind arg1 arg2 dbg = + match (kind : Lambda.array_kind) with + | Pgenarray -> + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + bind "header" (get_header_without_profinfo arr dbg) (fun hdr -> + if wordsize_shift = numfloat_shift then + Csequence( + make_checkbound dbg [addr_array_length_shifted hdr dbg; idx], + Cifthenelse(is_addr_array_hdr hdr dbg, + dbg, + addr_array_ref arr idx dbg, + dbg, + float_array_ref arr idx dbg, + dbg)) + else + Cifthenelse(is_addr_array_hdr hdr dbg, + dbg, + Csequence( + make_checkbound dbg [addr_array_length_shifted hdr dbg; idx], + addr_array_ref arr idx dbg), + dbg, + Csequence( + make_checkbound dbg [float_array_length_shifted hdr dbg; idx], + float_array_ref arr idx dbg), + dbg)))) + | Paddrarray -> + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + Csequence( + make_checkbound dbg [ + addr_array_length_shifted + (get_header_without_profinfo arr dbg) dbg; idx], + addr_array_ref arr idx dbg))) + | Pintarray -> + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + Csequence( + make_checkbound dbg [ + addr_array_length_shifted + (get_header_without_profinfo arr dbg) dbg; idx], + int_array_ref arr idx dbg))) + | Pfloatarray -> + box_float dbg ( + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + Csequence( + make_checkbound dbg [ + float_array_length_shifted + (get_header_without_profinfo arr dbg) dbg; + idx], + unboxed_float_array_ref arr idx dbg)))) + +type ternary_primitive = + expression -> expression -> expression -> Debuginfo.t -> expression + +let setfield_computed ptr init arg1 arg2 arg3 dbg = + match assignment_kind ptr init with + | Caml_modify -> + return_unit dbg (addr_array_set arg1 arg2 arg3 dbg) + | Caml_initialize -> + return_unit dbg (addr_array_initialize arg1 arg2 arg3 dbg) + | Simple -> + return_unit dbg (int_array_set arg1 arg2 arg3 dbg) + +let bytesset_unsafe arg1 arg2 arg3 dbg = + return_unit dbg (Cop(Cstore (Byte_unsigned, Assignment), + [add_int arg1 (untag_int arg2 dbg) dbg; + untag_int arg3 dbg], dbg)) + +let bytesset_safe arg1 arg2 arg3 dbg = + return_unit dbg + (bind "str" arg1 (fun str -> + bind "index" (untag_int arg2 dbg) (fun idx -> + Csequence( + make_checkbound dbg [string_length str dbg; idx], + Cop(Cstore (Byte_unsigned, Assignment), + [add_int str idx dbg; untag_int arg3 dbg], + dbg))))) + +let arrayset_unsafe kind arg1 arg2 arg3 dbg = + return_unit dbg (match (kind: Lambda.array_kind) with + | Pgenarray -> + bind "newval" arg3 (fun newval -> + bind "index" arg2 (fun index -> + bind "arr" arg1 (fun arr -> + Cifthenelse(is_addr_array_ptr arr dbg, + dbg, + addr_array_set arr index newval dbg, + dbg, + float_array_set arr index (unbox_float dbg newval) + dbg, + dbg)))) + | Paddrarray -> + addr_array_set arg1 arg2 arg3 dbg + | Pintarray -> + int_array_set arg1 arg2 arg3 dbg + | Pfloatarray -> + float_array_set arg1 arg2 arg3 dbg + ) + +let arrayset_safe kind arg1 arg2 arg3 dbg = + return_unit dbg (match (kind: Lambda.array_kind) with + | Pgenarray -> + bind "newval" arg3 (fun newval -> + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + bind "header" (get_header_without_profinfo arr dbg) (fun hdr -> + if wordsize_shift = numfloat_shift then + Csequence( + make_checkbound dbg [addr_array_length_shifted hdr dbg; idx], + Cifthenelse(is_addr_array_hdr hdr dbg, + dbg, + addr_array_set arr idx newval dbg, + dbg, + float_array_set arr idx + (unbox_float dbg newval) + dbg, + dbg)) + else + Cifthenelse( + is_addr_array_hdr hdr dbg, + dbg, + Csequence( + make_checkbound dbg [addr_array_length_shifted hdr dbg; idx], + addr_array_set arr idx newval dbg), + dbg, + Csequence( + make_checkbound dbg [float_array_length_shifted hdr dbg; idx], + float_array_set arr idx + (unbox_float dbg newval) dbg), + dbg))))) + | Paddrarray -> + bind "newval" arg3 (fun newval -> + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + Csequence( + make_checkbound dbg [ + addr_array_length_shifted + (get_header_without_profinfo arr dbg) dbg; + idx], + addr_array_set arr idx newval dbg)))) + | Pintarray -> + bind "newval" arg3 (fun newval -> + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + Csequence( + make_checkbound dbg [ + addr_array_length_shifted + (get_header_without_profinfo arr dbg) dbg; + idx], + int_array_set arr idx newval dbg)))) + | Pfloatarray -> + bind_load "newval" arg3 (fun newval -> + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + Csequence( + make_checkbound dbg [ + float_array_length_shifted + (get_header_without_profinfo arr dbg) dbg; + idx], + float_array_set arr idx newval dbg)))) + ) + +let bytes_set size unsafe arg1 arg2 arg3 dbg = + return_unit dbg + (bind "str" arg1 (fun str -> + bind "index" (untag_int arg2 dbg) (fun idx -> + bind "newval" arg3 (fun newval -> + check_bound unsafe size dbg (string_length str dbg) + idx (unaligned_set size str idx newval dbg))))) + +let bigstring_set size unsafe arg1 arg2 arg3 dbg = + return_unit dbg + (bind "ba" arg1 (fun ba -> + bind "index" (untag_int arg2 dbg) (fun idx -> + bind "newval" arg3 (fun newval -> + bind "ba_data" + (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) + (fun ba_data -> + check_bound unsafe size dbg (bigstring_length ba dbg) + idx (unaligned_set size ba_data idx newval dbg)))))) + +(* Symbols *) + +let cdefine_symbol (symb, (global: Cmmgen_state.is_global)) = + match global with + | Global -> [Cglobal_symbol symb; Cdefine_symbol symb] + | Local -> [Cdefine_symbol symb] + +let emit_block symb white_header cont = + (* Headers for structured constants must be marked black in case we + are in no-naked-pointers mode. See [caml_darken]. *) + let black_header = Nativeint.logor white_header caml_black in + Cint black_header :: cdefine_symbol symb @ cont + +let emit_string_constant_fields s cont = + let n = size_int - 1 - (String.length s) mod size_int in + Cstring s :: Cskip n :: Cint8 n :: cont + +let emit_boxed_int32_constant_fields n cont = + let n = Nativeint.of_int32 n in + if size_int = 8 then + Csymbol_address caml_int32_ops :: Cint32 n :: Cint32 0n :: cont + else + Csymbol_address caml_int32_ops :: Cint n :: cont + +let emit_boxed_int64_constant_fields n cont = + let lo = Int64.to_nativeint n in + if size_int = 8 then + Csymbol_address caml_int64_ops :: Cint lo :: cont + else begin + let hi = Int64.to_nativeint (Int64.shift_right n 32) in + if big_endian then + Csymbol_address caml_int64_ops :: Cint hi :: Cint lo :: cont + else + Csymbol_address caml_int64_ops :: Cint lo :: Cint hi :: cont + end + +let emit_boxed_nativeint_constant_fields n cont = + Csymbol_address caml_nativeint_ops :: Cint n :: cont + +let emit_float_constant symb f cont = + emit_block symb float_header (Cdouble f :: cont) + +let emit_string_constant symb s cont = + emit_block symb (string_header (String.length s)) + (emit_string_constant_fields s cont) + +let emit_int32_constant symb n cont = + emit_block symb boxedint32_header + (emit_boxed_int32_constant_fields n cont) + +let emit_int64_constant symb n cont = + emit_block symb boxedint64_header + (emit_boxed_int64_constant_fields n cont) + +let emit_nativeint_constant symb n cont = + emit_block symb boxedintnat_header + (emit_boxed_nativeint_constant_fields n cont) + +let emit_float_array_constant symb fields cont = + emit_block symb (floatarray_header (List.length fields)) + (Misc.map_end (fun f -> Cdouble f) fields cont) + +(* Generate the entry point *) + +let entry_point namelist = + let dbg = placeholder_dbg in + let cconst_int i = Cconst_int (i, dbg ()) in + let cconst_symbol sym = Cconst_symbol (sym, dbg ()) in + let incr_global_inited () = + Cop(Cstore (Word_int, Assignment), + [cconst_symbol "caml_globals_inited"; + Cop(Caddi, [Cop(Cload (Word_int, Mutable), + [cconst_symbol "caml_globals_inited"], dbg ()); + cconst_int 1], dbg ())], dbg ()) in + let body = + List.fold_right + (fun name next -> + let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in + Csequence(Cop(Capply typ_void, + [cconst_symbol entry_sym], dbg ()), + Csequence(incr_global_inited (), next))) + namelist (cconst_int 1) in + let fun_name = "caml_program" in + let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in + Cfunction {fun_name; + fun_args = []; + fun_body = body; + fun_codegen_options = [Reduce_code_size]; + fun_dbg; + } + +(* Generate the table of globals *) + +let cint_zero = Cint 0n + +let global_table namelist = + let mksym name = + Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "gc_roots")) + in + Cdata(Cglobal_symbol "caml_globals" :: + Cdefine_symbol "caml_globals" :: + List.map mksym namelist @ + [cint_zero]) + +let reference_symbols namelist = + let mksym name = Csymbol_address name in + Cdata(List.map mksym namelist) + +let global_data name v = + Cdata(emit_string_constant (name, Global) + (Marshal.to_string v []) []) + +let globals_map v = global_data "caml_globals_map" v + +(* Generate the master table of frame descriptors *) + +let frame_table namelist = + let mksym name = + Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "frametable")) + in + Cdata(Cglobal_symbol "caml_frametable" :: + Cdefine_symbol "caml_frametable" :: + List.map mksym namelist + @ [cint_zero]) + +(* Generate the master table of Spacetime shapes *) + +let spacetime_shapes namelist = + let mksym name = + Csymbol_address ( + Compilenv.make_symbol ~unitname:name (Some "spacetime_shapes")) + in + Cdata(Cglobal_symbol "caml_spacetime_shapes" :: + Cdefine_symbol "caml_spacetime_shapes" :: + List.map mksym namelist + @ [cint_zero]) + +(* Generate the table of module data and code segments *) + +let segment_table namelist symbol begname endname = + let addsyms name lst = + Csymbol_address (Compilenv.make_symbol ~unitname:name (Some begname)) :: + Csymbol_address (Compilenv.make_symbol ~unitname:name (Some endname)) :: + lst + in + Cdata(Cglobal_symbol symbol :: + Cdefine_symbol symbol :: + List.fold_right addsyms namelist [cint_zero]) + +let data_segment_table namelist = + segment_table namelist "caml_data_segments" "data_begin" "data_end" + +let code_segment_table namelist = + segment_table namelist "caml_code_segments" "code_begin" "code_end" + +(* Initialize a predefined exception *) + +let predef_exception i name = + let name_sym = Compilenv.new_const_symbol () in + let data_items = + emit_string_constant (name_sym, Local) name [] + in + let exn_sym = "caml_exn_" ^ name in + let tag = Obj.object_tag in + let size = 2 in + let fields = + (Csymbol_address name_sym) + :: (cint_const (-i - 1)) + :: data_items + in + let data_items = + emit_block (exn_sym, Global) (block_header tag size) fields + in + Cdata data_items + +(* Header for a plugin *) + +let plugin_header units = + let mk ((ui : Cmx_format.unit_infos),crc) : Cmxs_format.dynunit = + { dynu_name = ui.ui_name; + dynu_crc = crc; + dynu_imports_cmi = ui.ui_imports_cmi; + dynu_imports_cmx = ui.ui_imports_cmx; + dynu_defines = ui.ui_defines + } in + global_data "caml_plugin_header" + ({ dynu_magic = Config.cmxs_magic_number; + dynu_units = List.map mk units } + : Cmxs_format.dynheader) + +(* To compile "let rec" over values *) + +let fundecls_size fundecls = + let sz = ref (-1) in + List.iter + (fun (f : Clambda.ufunction) -> + let indirect_call_code_pointer_size = + match f.arity with + | 0 | 1 -> 0 + (* arity 1 does not need an indirect call handler. + arity 0 cannot be indirect called *) + | _ -> 1 + (* For other arities there is an indirect call handler. + if arity >= 2 it is caml_curry... + if arity < 0 it is caml_tuplify... *) + in + sz := !sz + 1 + 2 + indirect_call_code_pointer_size) + fundecls; + !sz + +(* Emit constant closures *) + +let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = + let closure_symbol (f : Clambda.ufunction) = + if Config.flambda then + cdefine_symbol (f.label ^ "_closure", global_symb) + else + [] + in + match (fundecls : Clambda.ufunction list) with + [] -> + (* This should probably not happen: dead code has normally been + eliminated and a closure cannot be accessed without going through + a [Project_closure], which depends on the function. *) + assert (clos_vars = []); + cdefine_symbol symb @ clos_vars @ cont + | f1 :: remainder -> + let rec emit_others pos = function + [] -> clos_vars @ cont + | (f2 : Clambda.ufunction) :: rem -> + if f2.arity = 1 || f2.arity = 0 then + Cint(infix_header pos) :: + (closure_symbol f2) @ + Csymbol_address f2.label :: + cint_const f2.arity :: + emit_others (pos + 3) rem + else + Cint(infix_header pos) :: + (closure_symbol f2) @ + Csymbol_address(curry_function_sym f2.arity) :: + cint_const f2.arity :: + Csymbol_address f2.label :: + emit_others (pos + 4) rem in + Cint(black_closure_header (fundecls_size fundecls + + List.length clos_vars)) :: + cdefine_symbol symb @ + (closure_symbol f1) @ + if f1.arity = 1 || f1.arity = 0 then + Csymbol_address f1.label :: + cint_const f1.arity :: + emit_others 3 remainder + else + Csymbol_address(curry_function_sym f1.arity) :: + cint_const f1.arity :: + Csymbol_address f1.label :: + emit_others 4 remainder + +(* Build the NULL terminated array of gc roots *) + +let emit_gc_roots_table ~symbols cont = + let table_symbol = Compilenv.make_symbol (Some "gc_roots") in + Cdata(Cglobal_symbol table_symbol :: + Cdefine_symbol table_symbol :: + List.map (fun s -> Csymbol_address s) symbols @ + [Cint 0n]) + :: cont + +(* Build preallocated blocks (used for Flambda [Initialize_symbol] + constructs, and Clambda global module) *) + +let preallocate_block cont { Clambda.symbol; exported; tag; fields } = + let space = + (* These words will be registered as roots and as such must contain + valid values, in case we are in no-naked-pointers mode. Likewise + the block header must be black, below (see [caml_darken]), since + the overall record may be referenced. *) + List.map (fun field -> + match field with + | None -> + Cint (Nativeint.of_int 1 (* Val_unit *)) + | Some (Clambda.Uconst_field_int n) -> + cint_const n + | Some (Clambda.Uconst_field_ref label) -> + Csymbol_address label) + fields + in + let global = Cmmgen_state.(if exported then Global else Local) in + let symb = (symbol, global) in + let data = + emit_block symb (block_header tag (List.length fields)) space + in + Cdata data :: cont + +let emit_preallocated_blocks preallocated_blocks cont = + let symbols = + List.map (fun ({ Clambda.symbol }:Clambda.preallocated_block) -> symbol) + preallocated_blocks + in + let c1 = emit_gc_roots_table ~symbols cont in + List.fold_left preallocate_block c1 preallocated_blocks diff --git a/asmcomp/cmm_helpers.mli b/asmcomp/cmm_helpers.mli new file mode 100644 index 0000000000..c4a7e428cf --- /dev/null +++ b/asmcomp/cmm_helpers.mli @@ -0,0 +1,641 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Cmm + +(** [bind name arg fn] is equivalent to [let name = arg in fn name], + or simply [fn arg] if [arg] is simple enough *) +val bind : + string -> expression -> (expression -> expression) -> expression + +(** Same as [bind], but also treats loads from a variable as simple *) +val bind_load : + string -> expression -> (expression -> expression) -> expression + +(** Same as [bind], but does not treat variables as simple *) +val bind_nonvar : + string -> expression -> (expression -> expression) -> expression + +(** Headers *) + +(** A null header with GC bits set to black *) +val caml_black : nativeint + +(** A constant equal to the tag for float arrays *) +val floatarray_tag : Debuginfo.t -> expression + +(** [block_header tag size] creates a header with tag [tag] for a + block of size [size] *) +val block_header : int -> int -> nativeint + +(** Same as block_header, but with GC bits set to black *) +val black_block_header : int -> int -> nativeint + +(** Closure headers of the given size *) +val white_closure_header : int -> nativeint +val black_closure_header : int -> nativeint + +(** Infix header at the given offset *) +val infix_header : int -> nativeint + +(** Header for a boxed float value *) +val float_header : nativeint + +(** Header for an unboxed float array of the given size *) +val floatarray_header : int -> nativeint + +(** Header for a string (or bytes) of the given length *) +val string_header : int -> nativeint + +(** Boxed integer headers *) +val boxedint32_header : nativeint +val boxedint64_header : nativeint +val boxedintnat_header : nativeint + +(** Wrappers *) +val alloc_float_header : Debuginfo.t -> expression +val alloc_floatarray_header : int -> Debuginfo.t -> expression +val alloc_closure_header : int -> Debuginfo.t -> expression +val alloc_infix_header : int -> Debuginfo.t -> expression +val alloc_boxedint32_header : Debuginfo.t -> expression +val alloc_boxedint64_header : Debuginfo.t -> expression +val alloc_boxedintnat_header : Debuginfo.t -> expression + +(** Integers *) + +(** Minimal/maximal OCaml integer values whose backend representation fits + in a regular OCaml integer *) +val max_repr_int : int +val min_repr_int : int + +(** Make an integer constant from the given integer (tags the integer) *) +val int_const : Debuginfo.t -> int -> expression +val cint_const : int -> data_item +val targetint_const : int -> Targetint.t + +(** Make a Cmm constant holding the given nativeint value. + Uses [Cconst_int] instead of [Cconst_nativeint] when possible + to preserve peephole optimisations. *) +val natint_const_untagged : Debuginfo.t -> Nativeint.t -> expression + +(** Add an integer to the given expression *) +val add_const : expression -> int -> Debuginfo.t -> expression + +(** Increment/decrement of integers *) +val incr_int : expression -> Debuginfo.t -> expression +val decr_int : expression -> Debuginfo.t -> expression + +(** Simplify the given expression knowing its last bit will be + irrelevant *) +val ignore_low_bit_int : expression -> expression + +(** Arithmetical operations on integers *) +val add_int : expression -> expression -> Debuginfo.t -> expression +val sub_int : expression -> expression -> Debuginfo.t -> expression +val lsl_int : expression -> expression -> Debuginfo.t -> expression +val mul_int : expression -> expression -> Debuginfo.t -> expression +val lsr_int : expression -> expression -> Debuginfo.t -> expression +val asr_int : expression -> expression -> Debuginfo.t -> expression +val div_int : + expression -> expression -> Lambda.is_safe -> Debuginfo.t -> expression +val mod_int : + expression -> expression -> Lambda.is_safe -> Debuginfo.t -> expression + +(** Integer tagging + [tag_int] and [force_tag_int] are functionally equivalent, but + produce syntactically different expressions ([tag_int] produces + an addition, while [force_tag_int] produces a logical or). + The difference marks the fact that the shift operation in [tag_int] + is assumed not to overflow, and so [untag_int (tag_int i)] can be + simplified to [i]. With [force_tag_int], the initial shift might + overflow, so the above simplification would be wrong. *) +val tag_int : expression -> Debuginfo.t -> expression +val force_tag_int : expression -> Debuginfo.t -> expression + +(** Integer untagging *) +val untag_int : expression -> Debuginfo.t -> expression + +(** Specific division operations for boxed integers *) +val safe_div_bi : + Lambda.is_safe -> + expression -> + expression -> + Primitive.boxed_integer -> + Debuginfo.t -> + expression +val safe_mod_bi : + Lambda.is_safe -> + expression -> + expression -> + Primitive.boxed_integer -> + Debuginfo.t -> + expression + +(** If-Then-Else expression + [mk_if_then_else dbg cond ifso_dbg ifso ifnot_dbg ifnot] associates + [dbg] to the global if-then-else expression, [ifso_dbg] to the + then branch [ifso], and [ifnot_dbg] to the else branch [ifnot] *) +val mk_if_then_else : + Debuginfo.t -> + expression -> + Debuginfo.t -> expression -> + Debuginfo.t -> expression -> + expression + +(** Boolean negation *) +val mk_not : Debuginfo.t -> expression -> expression + +(** Loop construction (while true do expr done). + Used to be represented as Cloop. *) +val create_loop : expression -> Debuginfo.t -> expression + +(** Exception raising *) +val raise_symbol : Debuginfo.t -> string -> expression + +(** Convert a tagged integer into a raw integer with boolean meaning *) +val test_bool : Debuginfo.t -> expression -> expression + +(** Float boxing and unboxing *) +val box_float : Debuginfo.t -> expression -> expression +val unbox_float : Debuginfo.t -> expression -> expression + +(** Complex number creation and access *) +val box_complex : Debuginfo.t -> expression -> expression -> expression +val complex_re : expression -> Debuginfo.t -> expression +val complex_im : expression -> Debuginfo.t -> expression + +(** Make the given expression return a unit value *) +val return_unit : Debuginfo.t -> expression -> expression + +(** Remove a trailing unit return if any *) +val remove_unit : expression -> expression + +(** Blocks *) + +(** [field_address ptr n dbg] returns an expression for the address of the + [n]th field of the block pointed to by [ptr] *) +val field_address : expression -> int -> Debuginfo.t -> expression + +(** [get_field_gen mut ptr n dbg] returns an expression for the access to the + [n]th field of the block pointed to by [ptr] *) +val get_field_gen : + Asttypes.mutable_flag -> expression -> int -> Debuginfo.t -> expression + +(** [set_field ptr n newval init dbg] returns an expression for setting the + [n]th field of the block pointed to by [ptr] to [newval] *) +val set_field : + expression -> int -> expression -> Lambda.initialization_or_assignment -> + Debuginfo.t -> expression + +(** Load a block's header *) +val get_header : expression -> Debuginfo.t -> expression + +(** Same as [get_header], but also set all profiling bits of the header + are to 0 (if profiling is enabled) *) +val get_header_without_profinfo : expression -> Debuginfo.t -> expression + +(** Load a block's tag *) +val get_tag : expression -> Debuginfo.t -> expression + +(** Load a block's size *) +val get_size : expression -> Debuginfo.t -> expression + +(** Arrays *) + +val wordsize_shift : int +val numfloat_shift : int + +(** Check whether the given array is an array of regular OCaml values + (as opposed to unboxed floats), from its header or pointer *) +val is_addr_array_hdr : expression -> Debuginfo.t -> expression +val is_addr_array_ptr : expression -> Debuginfo.t -> expression + +(** Get the length of an array from its header + Shifts by one bit less than necessary, keeping one of the GC colour bits, + to save an operation when returning the length as a caml integer or when + comparing it to a caml integer. + Assumes the header does not have any profiling info + (as returned by get_header_without_profinfo) *) +val addr_array_length_shifted : expression -> Debuginfo.t -> expression +val float_array_length_shifted : expression -> Debuginfo.t -> expression + +(** For [array_indexing ?typ log2size ptr ofs dbg] : + Produces a pointer to the element of the array [ptr] on the position [ofs] + with the given element [log2size] log2 element size. [ofs] is given as a + tagged int expression. + The optional ?typ argument is the C-- type of the result. + By default, it is Addr, meaning we are constructing a derived pointer + into the heap. If we know the pointer is outside the heap + (this is the case for bigarray indexing), we give type Int instead. *) +val array_indexing : + ?typ:machtype_component -> int -> expression -> expression -> Debuginfo.t -> + expression + +(** Array loads and stores + [unboxed_float_array_ref] and [float_array_ref] differ in the + boxing of the result; [float_array_set] takes an unboxed float *) +val addr_array_ref : expression -> expression -> Debuginfo.t -> expression +val int_array_ref : expression -> expression -> Debuginfo.t -> expression +val unboxed_float_array_ref : + expression -> expression -> Debuginfo.t -> expression +val float_array_ref : expression -> expression -> Debuginfo.t -> expression +val addr_array_set : + expression -> expression -> expression -> Debuginfo.t -> expression +val addr_array_initialize : + expression -> expression -> expression -> Debuginfo.t -> expression +val int_array_set : + expression -> expression -> expression -> Debuginfo.t -> expression +val float_array_set : + expression -> expression -> expression -> Debuginfo.t -> expression + +(** Strings *) + +val string_length : expression -> Debuginfo.t -> expression +val bigstring_length : expression -> Debuginfo.t -> expression + +(** Objects *) + +(** Lookup a method by its hash, using [caml_get_public_method] + Arguments : + - obj : the object from which to lookup + - tag : the hash of the method name, as a tagged integer *) +val lookup_tag : expression -> expression -> Debuginfo.t -> expression + +(** Lookup a method by its offset in the method table + Arguments : + - obj : the object from which to lookup + - lab : the position of the required method in the object's + method array, as a tagged integer *) +val lookup_label : expression -> expression -> Debuginfo.t -> expression + +(** Lookup and call a method using the method cache + Arguments : + - obj : the object from which to lookup + - tag : the hash of the method name, as a tagged integer + - cache : the method cache array + - pos : the position of the cache entry in the cache array + - args : the additional arguments to the method call *) +val call_cached_method : + expression -> expression -> expression -> expression -> expression list -> + Debuginfo.t -> expression + +(** Allocations *) + +(** Allocate a block of regular values with the given tag *) +val make_alloc : Debuginfo.t -> int -> expression list -> expression + +(** Allocate a block of unboxed floats with the given tag *) +val make_float_alloc : Debuginfo.t -> int -> expression list -> expression + +(** Bounds checking *) + +(** Generate a [Ccheckbound] term *) +val make_checkbound : Debuginfo.t -> expression list -> expression + +(** [check_bound safety access_size dbg length a2 k] prefixes expression [k] + with a check that reading [access_size] bits starting at position [a2] + in a string/bytes value of length [length] is within bounds, unless + [safety] is [Unsafe]. *) +val check_bound : + Lambda.is_safe -> Clambda_primitives.memory_access_size -> Debuginfo.t -> + expression -> expression -> expression -> + expression + +(** Generic application functions *) + +(** Get the symbol for the generic application with [n] arguments, and + ensure its presence in the set of defined symbols *) +val apply_function_sym : int -> string + +(** If [n] is positive, get the symbol for the generic currying wrapper with + [n] arguments, and ensure its presence in the set of defined symbols. + Otherwise, do the same for the generic tuple wrapper with [-n] arguments. *) +val curry_function_sym : int -> string + +(** Bigarrays *) + +(** [bigarray_get unsafe kind layout b args dbg] + - unsafe : if true, do not insert bound checks + - kind : see [Lambda.bigarray_kind] + - layout : see [Lambda.bigarray_layout] + - b : the bigarray to load from + - args : a list of tagged integer expressions, corresponding to the + indices in the respective dimensions + - dbg : debugging information *) +val bigarray_get : + bool -> Lambda.bigarray_kind -> Lambda.bigarray_layout -> + expression -> expression list -> Debuginfo.t -> + expression + +(** [bigarray_set unsafe kind layout b args newval dbg] + Same as [bigarray_get], with [newval] the value being assigned *) +val bigarray_set : + bool -> Lambda.bigarray_kind -> Lambda.bigarray_layout -> + expression -> expression list -> expression -> Debuginfo.t -> + expression + +(** Boxed numbers *) + +(** Global symbols for the ops field of boxed integers *) +val caml_nativeint_ops : string +val caml_int32_ops : string +val caml_int64_ops : string + +(** Box a given integer, without sharing of constants *) +val box_int_gen : + Debuginfo.t -> Primitive.boxed_integer -> expression -> expression + +(** Unbox a given boxed integer *) +val unbox_int : + Debuginfo.t -> Primitive.boxed_integer -> expression -> expression + +(** Used to prepare 32-bit integers on 64-bit platforms for a lsr operation *) +val make_unsigned_int : + Primitive.boxed_integer -> expression -> Debuginfo.t -> expression + +val unaligned_load_16 : expression -> expression -> Debuginfo.t -> expression +val unaligned_set_16 : + expression -> expression -> expression -> Debuginfo.t -> expression +val unaligned_load_32 : expression -> expression -> Debuginfo.t -> expression +val unaligned_set_32 : + expression -> expression -> expression -> Debuginfo.t -> expression +val unaligned_load_64 : expression -> expression -> Debuginfo.t -> expression +val unaligned_set_64 : + expression -> expression -> expression -> Debuginfo.t -> expression + +(** Raw memory accesses *) + +(** [unaligned_set size ptr idx newval dbg] *) +val unaligned_set : + Clambda_primitives.memory_access_size -> + expression -> expression -> expression -> Debuginfo.t -> expression + +(** [unaligned_load size ptr idx dbg] *) +val unaligned_load : + Clambda_primitives.memory_access_size -> + expression -> expression -> Debuginfo.t -> expression + +(** [box_sized size dbg exp] *) +val box_sized : + Clambda_primitives.memory_access_size -> + Debuginfo.t -> expression -> expression + +(** Primitives *) + +val simplif_primitive : + Clambda_primitives.primitive -> Clambda_primitives.primitive + +type unary_primitive = expression -> Debuginfo.t -> expression + +(** Return the n-th field of a float array (or float-only record), as an + unboxed float *) +val floatfield : int -> unary_primitive + +(** Int_as_pointer primitive *) +val int_as_pointer : unary_primitive + +(** Raise primitive *) +val raise_prim : Lambda.raise_kind -> unary_primitive + +(** Unary negation of an OCaml integer *) +val negint : unary_primitive + +(** Add a constant number to an OCaml integer *) +val offsetint : int -> unary_primitive + +(** Add a constant number to an OCaml integer reference *) +val offsetref : int -> unary_primitive + +(** Return the length of the array argument, as an OCaml integer *) +val arraylength : Lambda.array_kind -> unary_primitive + +(** Byte swap primitive + Operates on Cmm integers (unboxed values) *) +val bbswap : Primitive.boxed_integer -> unary_primitive + +(** 16-bit byte swap primitive + Operates on Cmm integers (untagged integers) *) +val bswap16 : unary_primitive + +type binary_primitive = expression -> expression -> Debuginfo.t -> expression + +type assignment_kind = Caml_modify | Caml_initialize | Simple + +(** [setfield offset value_is_ptr init ptr value dbg] *) +val setfield : + int -> Lambda.immediate_or_pointer -> Lambda.initialization_or_assignment -> + binary_primitive + +(** [setfloatfield offset init ptr value dbg] + [value] is expected to be an unboxed floating point number *) +val setfloatfield : + int -> Lambda.initialization_or_assignment -> binary_primitive + +(** Operations on OCaml integers *) +val add_int_caml : binary_primitive +val sub_int_caml : binary_primitive +val mul_int_caml : binary_primitive +val div_int_caml : Lambda.is_safe -> binary_primitive +val mod_int_caml : Lambda.is_safe -> binary_primitive +val and_int_caml : binary_primitive +val or_int_caml : binary_primitive +val xor_int_caml : binary_primitive +val lsl_int_caml : binary_primitive +val lsr_int_caml : binary_primitive +val asr_int_caml : binary_primitive +val int_comp_caml : Lambda.integer_comparison -> binary_primitive + +(** Strings, Bytes and Bigstrings *) + +(** Regular string/bytes access. Args: string/bytes, index *) +val stringref_unsafe : binary_primitive +val stringref_safe : binary_primitive + +(** Load by chunk from string/bytes, bigstring. Args: string, index *) +val string_load : + Clambda_primitives.memory_access_size -> Lambda.is_safe -> binary_primitive +val bigstring_load : + Clambda_primitives.memory_access_size -> Lambda.is_safe -> binary_primitive + +(** Arrays *) + +(** Array access. Args: array, index *) +val arrayref_unsafe : Lambda.array_kind -> binary_primitive +val arrayref_safe : Lambda.array_kind -> binary_primitive + +type ternary_primitive = + expression -> expression -> expression -> Debuginfo.t -> expression + +(** Same as setfield, except the offset is one of the arguments. + Args: pointer (structure/array/...), index, value *) +val setfield_computed : + Lambda.immediate_or_pointer -> Lambda.initialization_or_assignment -> + ternary_primitive + +(** Set the byte at the given offset to the given value. + Args: bytes, index, value *) +val bytesset_unsafe : ternary_primitive +val bytesset_safe : ternary_primitive + +(** Set the element at the given index in the given array to the given value. + WARNING: if [kind] is [Pfloatarray], then [value] is expected to be an + _unboxed_ float. Otherwise, it is expected to be a regular caml value, + including in the case where the array contains floats. + Args: array, index, value *) +val arrayset_unsafe : Lambda.array_kind -> ternary_primitive +val arrayset_safe : Lambda.array_kind -> ternary_primitive + +(** Set a chunk of data in the given bytes or bigstring structure. + See also [string_load] and [bigstring_load]. + Note: [value] is expected to be an unboxed number of the given size. + Args: pointer, index, value *) +val bytes_set : + Clambda_primitives.memory_access_size -> Lambda.is_safe -> ternary_primitive +val bigstring_set : + Clambda_primitives.memory_access_size -> Lambda.is_safe -> ternary_primitive + +(** Switch *) + +(** [transl_isout h arg dbg] *) +val transl_isout : expression -> expression -> Debuginfo.t -> expression + +(** [make_switch arg cases actions dbg] : Generate a Cswitch construct, + or optimize as a static table lookup when possible. *) +val make_switch : + expression -> int array -> (expression * Debuginfo.t) array -> Debuginfo.t -> + expression + +(** [transl_int_switch loc arg low high cases default] *) +val transl_int_switch : + Location.t -> expression -> int -> int -> + (int * expression) list -> expression -> expression + +(** [transl_switch_clambda loc arg index cases] *) +val transl_switch_clambda : + Location.t -> expression -> int array -> expression array -> expression + +(** [strmatch_compile dbg arg default cases] *) +val strmatch_compile : + Debuginfo.t -> expression -> expression option -> + (string * expression) list -> expression + +(** Closures and function applications *) + +(** Adds a constant offset to a pointer (for infix access) *) +val ptr_offset : expression -> int -> Debuginfo.t -> expression + +(** Direct application of a function via a symbol *) +val direct_apply : string -> expression list -> Debuginfo.t -> expression + +(** Generic application of a function to one or several arguments. + The mutable_flag argument annotates the loading of the code pointer + from the closure. The Cmmgen code uses a mutable load by + default, with a special case when the load is from (the first function of) + the currently defined closure. *) +val generic_apply : + Asttypes.mutable_flag -> + expression -> expression list -> Debuginfo.t -> expression + +(** Method call : [send kind met obj args dbg] + - [met] is a method identifier, which can be a hashed variant or an index + in [obj]'s method table, depending on [kind] + - [obj] is the object whose method is being called + - [args] is the extra arguments to the method call (Note: I'm not aware + of any way for the frontend to generate any arguments other than the + cache and cache position) *) +val send : + Lambda.meth_kind -> expression -> expression -> expression list -> + Debuginfo.t -> expression + +(** Generic Cmm fragments *) + +(** Generate generic functions *) +val generic_functions : bool -> Cmx_format.unit_infos list -> Cmm.phrase list + +val placeholder_dbg : unit -> Debuginfo.t +val placeholder_fun_dbg : human_name:string -> Debuginfo.t + +(** Entry point *) +val entry_point : string list -> phrase + +(** Generate the caml_globals table *) +val global_table: string list -> phrase + +(** Add references to the given symbols *) +val reference_symbols: string list -> phrase + +(** Generate the caml_globals_map structure, as a marshalled string constant *) +val globals_map: + (string * Digest.t option * Digest.t option * string list) list -> phrase + +(** Generate the caml_frametable table, referencing the frametables + from the given compilation units *) +val frame_table: string list -> phrase + +(** Generate the caml_spacetime_shapes table, referencing the spacetime shapes + from the given compilation units *) +val spacetime_shapes: string list -> phrase + +(** Generate the tables for data and code positions respectively of the given + compilation units *) +val data_segment_table: string list -> phrase +val code_segment_table: string list -> phrase + +(** Generate data for a predefined exception *) +val predef_exception: int -> string -> phrase + +val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> phrase + +(** Emit constant symbols *) + +(** Produce the data_item list corresponding to a symbol definition *) +val cdefine_symbol : (string * Cmmgen_state.is_global) -> data_item list + +(** [emit_block symb white_header cont] prepends to [cont] the header and symbol + for the block. + [cont] must already contain the fields of the block (and may contain + additional data items afterwards). *) +val emit_block : + (string * Cmmgen_state.is_global) -> nativeint -> data_item list -> + data_item list + +(** Emit specific kinds of constant blocks as data items *) +val emit_float_constant : + (string * Cmmgen_state.is_global) -> float -> data_item list -> + data_item list +val emit_string_constant : + (string * Cmmgen_state.is_global) -> string -> data_item list -> + data_item list +val emit_int32_constant : + (string * Cmmgen_state.is_global) -> int32 -> data_item list -> + data_item list +val emit_int64_constant : + (string * Cmmgen_state.is_global) -> int64 -> data_item list -> + data_item list +val emit_nativeint_constant : + (string * Cmmgen_state.is_global) -> nativeint -> data_item list -> + data_item list +val emit_float_array_constant : + (string * Cmmgen_state.is_global) -> float list -> data_item list -> + data_item list + +val fundecls_size : Clambda.ufunction list -> int + +val emit_constant_closure : + (string * Cmmgen_state.is_global) -> Clambda.ufunction list -> + data_item list -> data_item list -> data_item list + +val emit_preallocated_blocks : + Clambda.preallocated_block list -> phrase list -> phrase list diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 41ad7f65a6..149a2a8f9d 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -26,13 +26,12 @@ open Lambda open Clambda open Clambda_primitives open Cmm -open Cmx_format -open Cmxs_format module String = Misc.Stdlib.String module IntMap = Map.Make(Int) module V = Backend_var module VP = Backend_var.With_provenance +open Cmm_helpers (* Environments used for translation to Cmm. *) @@ -92,238 +91,6 @@ let notify_catch i env l = | Some f -> f l | None -> () -let structured_constant_of_sym s = - match Compilenv.structured_constant_of_symbol s with - | None -> Cmmgen_state.get_structured_constant s - | Some _ as r -> r - -(* Local binding of complex expressions *) - -let bind name arg fn = - match arg with - Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ - | Cblockheader _ -> fn arg - | _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id)) - -let bind_load name arg fn = - match arg with - | Cop(Cload _, [Cvar _], _) -> fn arg - | _ -> bind name arg fn - -let bind_nonvar name arg fn = - match arg with - Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ - | Cblockheader _ -> fn arg - | _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id)) - -let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 - (* cf. runtime/caml/gc.h *) - -(* Block headers. Meaning of the tag field: see stdlib/obj.ml *) - -let floatarray_tag dbg = Cconst_int (Obj.double_array_tag, dbg) - -let block_header tag sz = - Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) - (Nativeint.of_int tag) -(* Static data corresponding to "value"s must be marked black in case we are - in no-naked-pointers mode. See [caml_darken] and the code below that emits - structured constants and static module definitions. *) -let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black -let white_closure_header sz = block_header Obj.closure_tag sz -let black_closure_header sz = black_block_header Obj.closure_tag sz -let infix_header ofs = block_header Obj.infix_tag ofs -let float_header = block_header Obj.double_tag (size_float / size_addr) -let floatarray_header len = - (* Zero-sized float arrays have tag zero for consistency with - [caml_alloc_float_array]. *) - assert (len >= 0); - if len = 0 then block_header 0 0 - else block_header Obj.double_array_tag (len * size_float / size_addr) -let string_header len = - block_header Obj.string_tag ((len + size_addr) / size_addr) -let boxedint32_header = block_header Obj.custom_tag 2 -let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr) -let boxedintnat_header = block_header Obj.custom_tag 2 -let caml_nativeint_ops = "caml_nativeint_ops" -let caml_int32_ops = "caml_int32_ops" -let caml_int64_ops = "caml_int64_ops" - - -let alloc_float_header dbg = Cblockheader (float_header, dbg) -let alloc_floatarray_header len dbg = Cblockheader (floatarray_header len, dbg) -let alloc_closure_header sz dbg = Cblockheader (white_closure_header sz, dbg) -let alloc_infix_header ofs dbg = Cblockheader (infix_header ofs, dbg) -let alloc_boxedint32_header dbg = Cblockheader (boxedint32_header, dbg) -let alloc_boxedint64_header dbg = Cblockheader (boxedint64_header, dbg) -let alloc_boxedintnat_header dbg = Cblockheader (boxedintnat_header, dbg) - -(* Integers *) - -let max_repr_int = max_int asr 1 -let min_repr_int = min_int asr 1 - -let int_const dbg n = - if n <= max_repr_int && n >= min_repr_int - then Cconst_int((n lsl 1) + 1, dbg) - else Cconst_natint - (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n, dbg) - -let natint_const_untagged dbg n = - if n > Nativeint.of_int max_int - || n < Nativeint.of_int min_int - then Cconst_natint (n,dbg) - else Cconst_int (Nativeint.to_int n, dbg) - -let cint_const n = - Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) - -let targetint_const n = - Targetint.add (Targetint.shift_left (Targetint.of_int n) 1) - Targetint.one - -let add_no_overflow n x c dbg = - let d = n + x in - if d = 0 then c else Cop(Caddi, [c; Cconst_int (d, dbg)], dbg) - -let rec add_const c n dbg = - if n = 0 then c - else match c with - | Cconst_int (x, _) when no_overflow_add x n -> Cconst_int (x + n, dbg) - | Cop(Caddi, [Cconst_int (x, _); c], _) - when no_overflow_add n x -> - add_no_overflow n x c dbg - | Cop(Caddi, [c; Cconst_int (x, _)], _) - when no_overflow_add n x -> - add_no_overflow n x c dbg - | Cop(Csubi, [Cconst_int (x, _); c], _) when no_overflow_add n x -> - Cop(Csubi, [Cconst_int (n + x, dbg); c], dbg) - | Cop(Csubi, [c; Cconst_int (x, _)], _) when no_overflow_sub n x -> - add_const c (n - x) dbg - | c -> Cop(Caddi, [c; Cconst_int (n, dbg)], dbg) - -let incr_int c dbg = add_const c 1 dbg -let decr_int c dbg = add_const c (-1) dbg - -let rec add_int c1 c2 dbg = - match (c1, c2) with - | (Cconst_int (n, _), c) | (c, Cconst_int (n, _)) -> - add_const c n dbg - | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), c2) -> - add_const (add_int c1 c2 dbg) n1 dbg - | (c1, Cop(Caddi, [c2; Cconst_int (n2, _)], _)) -> - add_const (add_int c1 c2 dbg) n2 dbg - | (_, _) -> - Cop(Caddi, [c1; c2], dbg) - -let rec sub_int c1 c2 dbg = - match (c1, c2) with - | (c1, Cconst_int (n2, _)) when n2 <> min_int -> - add_const c1 (-n2) dbg - | (c1, Cop(Caddi, [c2; Cconst_int (n2, _)], _)) when n2 <> min_int -> - add_const (sub_int c1 c2 dbg) (-n2) dbg - | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), c2) -> - add_const (sub_int c1 c2 dbg) n1 dbg - | (c1, c2) -> - Cop(Csubi, [c1; c2], dbg) - -let rec lsl_int c1 c2 dbg = - match (c1, c2) with - | (Cop(Clsl, [c; Cconst_int (n1, _)], _), Cconst_int (n2, _)) - when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 -> - Cop(Clsl, [c; Cconst_int (n1 + n2, dbg)], dbg) - | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), Cconst_int (n2, _)) - when no_overflow_lsl n1 n2 -> - add_const (lsl_int c1 c2 dbg) (n1 lsl n2) dbg - | (_, _) -> - Cop(Clsl, [c1; c2], dbg) - -let is_power2 n = n = 1 lsl Misc.log2 n - -and mult_power2 c n dbg = lsl_int c (Cconst_int (Misc.log2 n, dbg)) dbg - -let rec mul_int c1 c2 dbg = - match (c1, c2) with - | (c, Cconst_int (0, _)) | (Cconst_int (0, _), c) -> - Csequence (c, Cconst_int (0, dbg)) - | (c, Cconst_int (1, _)) | (Cconst_int (1, _), c) -> - c - | (c, Cconst_int(-1, _)) | (Cconst_int(-1, _), c) -> - sub_int (Cconst_int (0, dbg)) c dbg - | (c, Cconst_int (n, _)) when is_power2 n -> mult_power2 c n dbg - | (Cconst_int (n, _), c) when is_power2 n -> mult_power2 c n dbg - | (Cop(Caddi, [c; Cconst_int (n, _)], _), Cconst_int (k, _)) | - (Cconst_int (k, _), Cop(Caddi, [c; Cconst_int (n, _)], _)) - when no_overflow_mul n k -> - add_const (mul_int c (Cconst_int (k, dbg)) dbg) (n * k) dbg - | (c1, c2) -> - Cop(Cmuli, [c1; c2], dbg) - - -let ignore_low_bit_int = function - Cop(Caddi, - [(Cop(Clsl, [_; Cconst_int (n, _)], _) as c); Cconst_int (1, _)], _) - when n > 0 - -> c - | Cop(Cor, [c; Cconst_int (1, _)], _) -> c - | c -> c - -let lsr_int c1 c2 dbg = - match c2 with - Cconst_int (0, _) -> - c1 - | Cconst_int (n, _) when n > 0 -> - Cop(Clsr, [ignore_low_bit_int c1; c2], dbg) - | _ -> - Cop(Clsr, [c1; c2], dbg) - -let asr_int c1 c2 dbg = - match c2 with - Cconst_int (0, _) -> - c1 - | Cconst_int (n, _) when n > 0 -> - Cop(Casr, [ignore_low_bit_int c1; c2], dbg) - | _ -> - Cop(Casr, [c1; c2], dbg) - -let tag_int i dbg = - match i with - | Cconst_int (n, _) -> - int_const dbg n - | Cop(Casr, [c; Cconst_int (n, _)], _) when n > 0 -> - Cop(Cor, - [asr_int c (Cconst_int (n - 1, dbg)) dbg; Cconst_int (1, dbg)], - dbg) - | c -> - incr_int (lsl_int c (Cconst_int (1, dbg)) dbg) dbg - -let force_tag_int i dbg = - match i with - Cconst_int (n, _) -> - int_const dbg n - | Cop(Casr, [c; Cconst_int (n, _)], dbg') when n > 0 -> - Cop(Cor, [asr_int c (Cconst_int (n - 1, dbg)) dbg'; Cconst_int (1, dbg)], - dbg) - | c -> - Cop(Cor, [lsl_int c (Cconst_int (1, dbg)) dbg; Cconst_int (1, dbg)], dbg) - -let untag_int i dbg = - match i with - Cconst_int (n, _) -> Cconst_int(n asr 1, dbg) - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], _) -> - c - | Cop(Cor, [Cop(Casr, [c; Cconst_int (n, _)], _); Cconst_int (1, _)], _) - when n > 0 && n < size_int * 8 -> - Cop(Casr, [c; Cconst_int (n+1, dbg)], dbg) - | Cop(Cor, [Cop(Clsr, [c; Cconst_int (n, _)], _); Cconst_int (1, _)], _) - when n > 0 && n < size_int * 8 -> - Cop(Clsr, [c; Cconst_int (n+1, dbg)], dbg) - | Cop(Cor, [c; Cconst_int (1, _)], _) -> - Cop(Casr, [c; Cconst_int (1, dbg)], dbg) - | c -> Cop(Casr, [c; Cconst_int (1, dbg)], dbg) - (* Description of the "then" and "else" continuations in [transl_if]. If the "then" continuation is true and the "else" continuation is false then we can use the condition directly as the result. Similarly, if the "then" @@ -339,580 +106,20 @@ let invert_then_else = function | Then_false_else_true -> Then_true_else_false | Unknown -> Unknown -let mk_if_then_else dbg cond ifso_dbg ifso ifnot_dbg ifnot = - match cond with - | Cconst_int (0, _) -> ifnot - | Cconst_int (1, _) -> ifso - | _ -> - Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) - -let mk_not dbg cmm = - match cmm with - | Cop(Caddi, - [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], dbg') -> - begin - match c with - | Cop(Ccmpi cmp, [c1; c2], dbg'') -> - tag_int - (Cop(Ccmpi (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg' - | Cop(Ccmpa cmp, [c1; c2], dbg'') -> - tag_int - (Cop(Ccmpa (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg' - | Cop(Ccmpf cmp, [c1; c2], dbg'') -> - tag_int - (Cop(Ccmpf (negate_float_comparison cmp), [c1; c2], dbg'')) dbg' - | _ -> - (* 0 -> 3, 1 -> 1 *) - Cop(Csubi, - [Cconst_int (3, dbg); Cop(Clsl, [c; Cconst_int (1, dbg)], dbg)], dbg) - end - | Cconst_int (3, _) -> Cconst_int (1, dbg) - | Cconst_int (1, _) -> Cconst_int (3, dbg) - | c -> - (* 1 -> 3, 3 -> 1 *) - Cop(Csubi, [Cconst_int (4, dbg); c], dbg) - - -let create_loop body dbg = - let cont = next_raise_count () in - let call_cont = Cexit (cont, []) in - let body = Csequence (body, call_cont) in - Ccatch (Recursive, [cont, [], body, dbg], call_cont) - -(* Turning integer divisions into multiply-high then shift. - The [division_parameters] function is used in module Emit for - those target platforms that support this optimization. *) - -(* Unsigned comparison between native integers. *) - -let ucompare x y = Nativeint.(compare (add x min_int) (add y min_int)) - -(* Unsigned division and modulus at type nativeint. - Algorithm: Hacker's Delight section 9.3 *) - -let udivmod n d = Nativeint.( - if d < 0n then - if ucompare n d < 0 then (0n, n) else (1n, sub n d) - else begin - let q = shift_left (div (shift_right_logical n 1) d) 1 in - let r = sub n (mul q d) in - if ucompare r d >= 0 then (succ q, sub r d) else (q, r) - end) - -(* Compute division parameters. - Algorithm: Hacker's Delight chapter 10, fig 10-1. *) - -let divimm_parameters d = Nativeint.( - assert (d > 0n); - let twopsm1 = min_int in (* 2^31 for 32-bit archs, 2^63 for 64-bit archs *) - let nc = sub (pred twopsm1) (snd (udivmod twopsm1 d)) in - let rec loop p (q1, r1) (q2, r2) = - let p = p + 1 in - let q1 = shift_left q1 1 and r1 = shift_left r1 1 in - let (q1, r1) = - if ucompare r1 nc >= 0 then (succ q1, sub r1 nc) else (q1, r1) in - let q2 = shift_left q2 1 and r2 = shift_left r2 1 in - let (q2, r2) = - if ucompare r2 d >= 0 then (succ q2, sub r2 d) else (q2, r2) in - let delta = sub d r2 in - if ucompare q1 delta < 0 || (q1 = delta && r1 = 0n) - then loop p (q1, r1) (q2, r2) - else (succ q2, p - size) - in loop (size - 1) (udivmod twopsm1 nc) (udivmod twopsm1 d)) - -(* The result [(m, p)] of [divimm_parameters d] satisfies the following - inequality: - - 2^(wordsize + p) < m * d <= 2^(wordsize + p) + 2^(p + 1) (i) - - from which it follows that - - floor(n / d) = floor(n * m / 2^(wordsize+p)) - if 0 <= n < 2^(wordsize-1) - ceil(n / d) = floor(n * m / 2^(wordsize+p)) + 1 - if -2^(wordsize-1) <= n < 0 - - The correctness condition (i) above can be checked by the code below. - It was exhaustively tested for values of d from 2 to 10^9 in the - wordsize = 64 case. - -let add2 (xh, xl) (yh, yl) = - let zl = add xl yl and zh = add xh yh in - ((if ucompare zl xl < 0 then succ zh else zh), zl) - -let shl2 (xh, xl) n = - assert (0 < n && n < size + size); - if n < size - then (logor (shift_left xh n) (shift_right_logical xl (size - n)), - shift_left xl n) - else (shift_left xl (n - size), 0n) - -let mul2 x y = - let halfsize = size / 2 in - let halfmask = pred (shift_left 1n halfsize) in - let xl = logand x halfmask and xh = shift_right_logical x halfsize in - let yl = logand y halfmask and yh = shift_right_logical y halfsize in - add2 (mul xh yh, 0n) - (add2 (shl2 (0n, mul xl yh) halfsize) - (add2 (shl2 (0n, mul xh yl) halfsize) - (0n, mul xl yl))) - -let ucompare2 (xh, xl) (yh, yl) = - let c = ucompare xh yh in if c = 0 then ucompare xl yl else c - -let validate d m p = - let md = mul2 m d in - let one2 = (0n, 1n) in - let twoszp = shl2 one2 (size + p) in - let twop1 = shl2 one2 (p + 1) in - ucompare2 twoszp md < 0 && ucompare2 md (add2 twoszp twop1) <= 0 -*) - -let raise_symbol dbg symb = - Cop(Craise Lambda.Raise_regular, [Cconst_symbol (symb, dbg)], dbg) - -let rec div_int c1 c2 is_safe dbg = - match (c1, c2) with - (c1, Cconst_int (0, _)) -> - Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") - | (c1, Cconst_int (1, _)) -> - c1 - | (Cconst_int (n1, _), Cconst_int (n2, _)) -> - Cconst_int (n1 / n2, dbg) - | (c1, Cconst_int (n, _)) when n <> min_int -> - let l = Misc.log2 n in - if n = 1 lsl l then - (* Algorithm: - t = shift-right-signed(c1, l - 1) - t = shift-right(t, W - l) - t = c1 + t - res = shift-right-signed(c1 + t, l) - *) - Cop(Casr, [bind "dividend" c1 (fun c1 -> - let t = asr_int c1 (Cconst_int (l - 1, dbg)) dbg in - let t = - lsr_int t (Cconst_int (Nativeint.size - l, dbg)) dbg - in - add_int c1 t dbg); - Cconst_int (l, dbg)], dbg) - else if n < 0 then - sub_int (Cconst_int (0, dbg)) - (div_int c1 (Cconst_int (-n, dbg)) is_safe dbg) - dbg - else begin - let (m, p) = divimm_parameters (Nativeint.of_int n) in - (* Algorithm: - t = multiply-high-signed(c1, m) - if m < 0, t = t + c1 - if p > 0, t = shift-right-signed(t, p) - res = t + sign-bit(c1) - *) - bind "dividend" c1 (fun c1 -> - let t = Cop(Cmulhi, [c1; Cconst_natint (m, dbg)], dbg) in - let t = if m < 0n then Cop(Caddi, [t; c1], dbg) else t in - let t = - if p > 0 then Cop(Casr, [t; Cconst_int (p, dbg)], dbg) else t - in - add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1, dbg)) dbg) dbg) - end - | (c1, c2) when !Clflags.unsafe || is_safe = Lambda.Unsafe -> - Cop(Cdivi, [c1; c2], dbg) - | (c1, c2) -> - bind "divisor" c2 (fun c2 -> - bind "dividend" c1 (fun c1 -> - Cifthenelse(c2, - dbg, - Cop(Cdivi, [c1; c2], dbg), - dbg, - raise_symbol dbg "caml_exn_Division_by_zero", - dbg))) - -let mod_int c1 c2 is_safe dbg = - match (c1, c2) with - (c1, Cconst_int (0, _)) -> - Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") - | (c1, Cconst_int ((1 | (-1)), _)) -> - Csequence(c1, Cconst_int (0, dbg)) - | (Cconst_int (n1, _), Cconst_int (n2, _)) -> - Cconst_int (n1 mod n2, dbg) - | (c1, (Cconst_int (n, _) as c2)) when n <> min_int -> - let l = Misc.log2 n in - if n = 1 lsl l then - (* Algorithm: - t = shift-right-signed(c1, l - 1) - t = shift-right(t, W - l) - t = c1 + t - t = bit-and(t, -n) - res = c1 - t - *) - bind "dividend" c1 (fun c1 -> - let t = asr_int c1 (Cconst_int (l - 1, dbg)) dbg in - let t = lsr_int t (Cconst_int (Nativeint.size - l, dbg)) dbg in - let t = add_int c1 t dbg in - let t = Cop(Cand, [t; Cconst_int (-n, dbg)], dbg) in - sub_int c1 t dbg) - else - bind "dividend" c1 (fun c1 -> - sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2 dbg) dbg) - | (c1, c2) when !Clflags.unsafe || is_safe = Lambda.Unsafe -> - (* Flambda already generates that test *) - Cop(Cmodi, [c1; c2], dbg) - | (c1, c2) -> - bind "divisor" c2 (fun c2 -> - bind "dividend" c1 (fun c1 -> - Cifthenelse(c2, - dbg, - Cop(Cmodi, [c1; c2], dbg), - dbg, - raise_symbol dbg "caml_exn_Division_by_zero", - dbg))) - -(* Division or modulo on boxed integers. The overflow case min_int / -1 - can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) - -let is_different_from x = function - Cconst_int (n, _) -> n <> x - | Cconst_natint (n, _) -> n <> Nativeint.of_int x - | _ -> false - -let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg = - bind "dividend" c1 (fun c1 -> - bind "divisor" c2 (fun c2 -> - let c = mkop c1 c2 is_safe dbg in - if Arch.division_crashes_on_overflow - && (size_int = 4 || bi <> Pint32) - && not (is_different_from (-1) c2) - then - Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int (-1, dbg)], dbg), - dbg, c, - dbg, mkm1 c1 dbg, - dbg) - else - c)) - -let safe_div_bi is_safe = - safe_divmod_bi div_int is_safe - (fun c1 dbg -> Cop(Csubi, [Cconst_int (0, dbg); c1], dbg)) - -let safe_mod_bi is_safe = - safe_divmod_bi mod_int is_safe (fun _ dbg -> Cconst_int (0, dbg)) - -(* Bool *) - -let test_bool dbg cmm = - match cmm with - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], _) -> - c - | Cconst_int (n, dbg) -> - if n = 1 then - Cconst_int (0, dbg) - else - Cconst_int (1, dbg) - | c -> Cop(Ccmpi Cne, [c; Cconst_int (1, dbg)], dbg) - -(* Float *) - -let box_float dbg c = Cop(Calloc, [alloc_float_header dbg; c], dbg) - -let unbox_float dbg = - map_tail - (function - | Cop(Calloc, [Cblockheader (hdr, _); c], _) - when Nativeint.equal hdr float_header -> - c - | Cconst_symbol (s, _dbg) as cmm -> - begin match structured_constant_of_sym s with - | Some (Uconst_float x) -> - Cconst_float (x, dbg) (* or keep _dbg? *) - | _ -> - Cop(Cload (Double_u, Immutable), [cmm], dbg) - end - | cmm -> Cop(Cload (Double_u, Immutable), [cmm], dbg) - ) - -(* Complex *) - -let box_complex dbg c_re c_im = - Cop(Calloc, [alloc_floatarray_header 2 dbg; c_re; c_im], dbg) - -let complex_re c dbg = Cop(Cload (Double_u, Immutable), [c], dbg) -let complex_im c dbg = Cop(Cload (Double_u, Immutable), - [Cop(Cadda, [c; Cconst_int (size_float, dbg)], dbg)], - dbg) - -(* Unit *) - -let return_unit dbg c = Csequence(c, Cconst_pointer (1, dbg)) - -let rec remove_unit = function - Cconst_pointer (1, _) -> Ctuple [] - | Csequence(c, Cconst_pointer (1, _)) -> c - | Csequence(c1, c2) -> - Csequence(c1, remove_unit c2) - | Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) -> - Cifthenelse(cond, - ifso_dbg, remove_unit ifso, - ifnot_dbg, - remove_unit ifnot, dbg) - | Cswitch(sel, index, cases, dbg) -> - Cswitch(sel, index, - Array.map (fun (case, dbg) -> remove_unit case, dbg) cases, - dbg) - | Ccatch(rec_flag, handlers, body) -> - let map_h (n, ids, handler, dbg) = (n, ids, remove_unit handler, dbg) in - Ccatch(rec_flag, List.map map_h handlers, remove_unit body) - | Ctrywith(body, exn, handler, dbg) -> - Ctrywith(remove_unit body, exn, remove_unit handler, dbg) - | Clet(id, c1, c2) -> - Clet(id, c1, remove_unit c2) - | Cop(Capply _mty, args, dbg) -> - Cop(Capply typ_void, args, dbg) - | Cop(Cextcall(proc, _mty, alloc, label_after), args, dbg) -> - Cop(Cextcall(proc, typ_void, alloc, label_after), args, dbg) - | Cexit (_,_) as c -> c - | Ctuple [] as c -> c - | c -> Csequence(c, Ctuple []) - -(* Access to block fields *) - -let field_address ptr n dbg = - if n = 0 - then ptr - else Cop(Cadda, [ptr; Cconst_int(n * size_addr, dbg)], dbg) +let mut_from_env env ptr = + match env.environment_param with + | None -> Mutable + | Some environment_param -> + match ptr with + | Cvar ptr -> + (* Loads from the current function's closure are immutable. *) + if V.same environment_param ptr then Immutable + else Mutable + | _ -> Mutable let get_field env ptr n dbg = - let mut = - match env.environment_param with - | None -> Mutable - | Some environment_param -> - match ptr with - | Cvar ptr -> - (* Loads from the current function's closure are immutable. *) - if V.same environment_param ptr then Immutable - else Mutable - | _ -> Mutable - in - Cop(Cload (Word_val, mut), [field_address ptr n dbg], dbg) - -let set_field ptr n newval init dbg = - Cop(Cstore (Word_val, init), [field_address ptr n dbg; newval], dbg) - -let non_profinfo_mask = - if Config.profinfo - then (1 lsl (64 - Config.profinfo_width)) - 1 - else 0 (* [non_profinfo_mask] is unused in this case *) - -let get_header ptr dbg = - (* We cannot deem this as [Immutable] due to the presence of [Obj.truncate] - and [Obj.set_tag]. *) - Cop(Cload (Word_int, Mutable), - [Cop(Cadda, [ptr; Cconst_int(-size_int, dbg)], dbg)], dbg) - -let get_header_without_profinfo ptr dbg = - if Config.profinfo then - Cop(Cand, [get_header ptr dbg; Cconst_int (non_profinfo_mask, dbg)], dbg) - else - get_header ptr dbg - -let tag_offset = - if big_endian then -1 else -size_int - -let get_tag ptr dbg = - if Proc.word_addressed then (* If byte loads are slow *) - Cop(Cand, [get_header ptr dbg; Cconst_int (255, dbg)], dbg) - else (* If byte loads are efficient *) - Cop(Cload (Byte_unsigned, Mutable), (* Same comment as [get_header] above *) - [Cop(Cadda, [ptr; Cconst_int(tag_offset, dbg)], dbg)], dbg) - -let get_size ptr dbg = - Cop(Clsr, [get_header_without_profinfo ptr dbg; Cconst_int (10, dbg)], dbg) - -(* Array indexing *) - -let log2_size_addr = Misc.log2 size_addr -let log2_size_float = Misc.log2 size_float - -let wordsize_shift = 9 -let numfloat_shift = 9 + log2_size_float - log2_size_addr - -let is_addr_array_hdr hdr dbg = - Cop(Ccmpi Cne, - [Cop(Cand, [hdr; Cconst_int (255, dbg)], dbg); floatarray_tag dbg], - dbg) - -let is_addr_array_ptr ptr dbg = - Cop(Ccmpi Cne, [get_tag ptr dbg; floatarray_tag dbg], dbg) - -let addr_array_length hdr dbg = - Cop(Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg) -let float_array_length hdr dbg = - Cop(Clsr, [hdr; Cconst_int (numfloat_shift, dbg)], dbg) - -let lsl_const c n dbg = - if n = 0 then c - else Cop(Clsl, [c; Cconst_int (n, dbg)], dbg) - -(* Produces a pointer to the element of the array [ptr] on the position [ofs] - with the given element [log2size] log2 element size. [ofs] is given as a - tagged int expression. - The optional ?typ argument is the C-- type of the result. - By default, it is Addr, meaning we are constructing a derived pointer - into the heap. If we know the pointer is outside the heap - (this is the case for bigarray indexing), we give type Int instead. *) - -let array_indexing ?typ log2size ptr ofs dbg = - let add = - match typ with - | None | Some Addr -> Cadda - | Some Int -> Caddi - | _ -> assert false in - match ofs with - | Cconst_int (n, _) -> - let i = n asr 1 in - if i = 0 then ptr - else Cop(add, [ptr; Cconst_int(i lsl log2size, dbg)], dbg) - | Cop(Caddi, - [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], dbg') -> - Cop(add, [ptr; lsl_const c log2size dbg], dbg') - | Cop(Caddi, [c; Cconst_int (n, _)], dbg') when log2size = 0 -> - Cop(add, - [Cop(add, [ptr; untag_int c dbg], dbg); Cconst_int (n asr 1, dbg)], - dbg') - | Cop(Caddi, [c; Cconst_int (n, _)], _) -> - Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1) dbg], dbg); - Cconst_int((n-1) lsl (log2size - 1), dbg)], dbg) - | _ when log2size = 0 -> - Cop(add, [ptr; untag_int ofs dbg], dbg) - | _ -> - Cop(add, [Cop(add, [ptr; lsl_const ofs (log2size - 1) dbg], dbg); - Cconst_int((-1) lsl (log2size - 1), dbg)], dbg) - -let addr_array_ref arr ofs dbg = - Cop(Cload (Word_val, Mutable), - [array_indexing log2_size_addr arr ofs dbg], dbg) -let int_array_ref arr ofs dbg = - Cop(Cload (Word_int, Mutable), - [array_indexing log2_size_addr arr ofs dbg], dbg) -let unboxed_float_array_ref arr ofs dbg = - Cop(Cload (Double_u, Mutable), - [array_indexing log2_size_float arr ofs dbg], dbg) -let float_array_ref dbg arr ofs = - box_float dbg (unboxed_float_array_ref arr ofs dbg) - -let addr_array_set arr ofs newval dbg = - Cop(Cextcall("caml_modify", typ_void, false, None), - [array_indexing log2_size_addr arr ofs dbg; newval], dbg) -let addr_array_initialize arr ofs newval dbg = - Cop(Cextcall("caml_initialize", typ_void, false, None), - [array_indexing log2_size_addr arr ofs dbg; newval], dbg) -let int_array_set arr ofs newval dbg = - Cop(Cstore (Word_int, Assignment), - [array_indexing log2_size_addr arr ofs dbg; newval], dbg) -let float_array_set arr ofs newval dbg = - Cop(Cstore (Double_u, Assignment), - [array_indexing log2_size_float arr ofs dbg; newval], dbg) - -(* String length *) - -(* Length of string block *) - -let string_length exp dbg = - bind "str" exp (fun str -> - let tmp_var = V.create_local "*tmp*" in - Clet(VP.create tmp_var, - Cop(Csubi, - [Cop(Clsl, - [get_size str dbg; - Cconst_int (log2_size_addr, dbg)], - dbg); - Cconst_int (1, dbg)], - dbg), - Cop(Csubi, - [Cvar tmp_var; - Cop(Cload (Byte_unsigned, Mutable), - [Cop(Cadda, [str; Cvar tmp_var], dbg)], dbg)], dbg))) - -let bigstring_length ba dbg = - Cop(Cload (Word_int, Mutable), [field_address ba 5 dbg], dbg) - -(* Message sending *) - -let lookup_tag obj tag dbg = - bind "tag" tag (fun tag -> - Cop(Cextcall("caml_get_public_method", typ_val, false, None), - [obj; tag], - dbg)) - -let lookup_label obj lab dbg = - bind "lab" lab (fun lab -> - let table = Cop (Cload (Word_val, Mutable), [obj], dbg) in - addr_array_ref table lab dbg) - -let call_cached_method obj tag cache pos args dbg = - let arity = List.length args in - let cache = array_indexing log2_size_addr cache pos dbg in - Compilenv.need_send_fun arity; - Cop(Capply typ_val, - Cconst_symbol("caml_send" ^ Int.to_string arity, dbg) :: - obj :: tag :: cache :: args, - dbg) - -(* Allocation *) - -let make_alloc_generic set_fn dbg tag wordsize args = - if wordsize <= Config.max_young_wosize then - Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg) - else begin - let id = V.create_local "*alloc*" in - let rec fill_fields idx = function - [] -> Cvar id - | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int (idx, dbg)) e1 dbg, - fill_fields (idx + 2) el) in - Clet(VP.create id, - Cop(Cextcall("caml_alloc", typ_val, true, None), - [Cconst_int (wordsize, dbg); Cconst_int (tag, dbg)], dbg), - fill_fields 1 args) - end - -let make_alloc dbg tag args = - let addr_array_init arr ofs newval dbg = - Cop(Cextcall("caml_initialize", typ_void, false, None), - [array_indexing log2_size_addr arr ofs dbg; newval], dbg) - in - make_alloc_generic addr_array_init dbg tag (List.length args) args - -let make_float_alloc dbg tag args = - make_alloc_generic float_array_set dbg tag - (List.length args * size_float / size_addr) args - -(* Bounds checking *) - -let make_checkbound dbg = function - | [Cop(Clsr, [a1; Cconst_int (n, _)], _); Cconst_int (m, _)] - when (m lsl n) > n -> - Cop(Ccheckbound, [a1; Cconst_int(m lsl n + 1 lsl n - 1, dbg)], dbg) - | args -> - Cop(Ccheckbound, args, dbg) - -(* To compile "let rec" over values *) - -let fundecls_size fundecls = - let sz = ref (-1) in - List.iter - (fun f -> - let indirect_call_code_pointer_size = - match f.arity with - | 0 | 1 -> 0 - (* arity 1 does not need an indirect call handler. - arity 0 cannot be indirect called *) - | _ -> 1 - (* For other arities there is an indirect call handler. - if arity >= 2 it is caml_curry... - if arity < 0 it is caml_tuplify... *) - in - sz := !sz + 1 + 2 + indirect_call_code_pointer_size) - fundecls; - !sz + let mut = mut_from_env env ptr in + get_field_gen mut ptr n dbg type rhs_kind = | RHS_block of int @@ -920,6 +127,7 @@ type rhs_kind = | RHS_floatblock of int | RHS_nonrec ;; + let rec expr_size env = function | Uvar id -> begin try V.find_same id env with Not_found -> RHS_nonrec end @@ -965,22 +173,6 @@ let rec expr_size env = function | _ -> assert false) | _ -> RHS_nonrec -(* Record application and currying functions *) - -let apply_function n = - Compilenv.need_apply_fun n; "caml_apply" ^ Int.to_string n -let curry_function n = - Compilenv.need_curry_fun n; - if n >= 0 - then "caml_curry" ^ Int.to_string n - else "caml_tuplify" ^ Int.to_string (-n) - -(* Comparisons *) - -let transl_int_comparison cmp = cmp - -let transl_float_comparison cmp = cmp - (* Translate structured constants to Cmm data items *) let transl_constant dbg = function @@ -995,105 +187,48 @@ let transl_constant dbg = function | Uconst_ref (label, _) -> Cconst_symbol (label, dbg) -let cdefine_symbol (symb, (global : Cmmgen_state.is_global)) = - match global with - | Global -> [Cglobal_symbol symb; Cdefine_symbol symb] - | Local -> [Cdefine_symbol symb] - -let emit_block symb is_global white_header cont = - (* Headers for structured constants must be marked black in case we - are in no-naked-pointers mode. See [caml_darken]. *) - let black_header = Nativeint.logor white_header caml_black in - Cint black_header :: cdefine_symbol (symb, is_global) @ cont +let emit_constant cst cont = + match cst with + | Uconst_int n | Uconst_ptr n -> + cint_const n + :: cont + | Uconst_ref (sym, _) -> + Csymbol_address sym :: cont -let rec emit_structured_constant (sym, is_global) cst cont = +let emit_structured_constant ((_sym, is_global) as symb) cst cont = match cst with | Uconst_float s -> - emit_block sym is_global float_header (Cdouble s :: cont) + emit_float_constant symb s cont | Uconst_string s -> - emit_block sym is_global (string_header (String.length s)) - (emit_string_constant s cont) + emit_string_constant symb s cont | Uconst_int32 n -> - emit_block sym is_global boxedint32_header - (emit_boxed_int32_constant n cont) + emit_int32_constant symb n cont | Uconst_int64 n -> - emit_block sym is_global boxedint64_header - (emit_boxed_int64_constant n cont) + emit_int64_constant symb n cont | Uconst_nativeint n -> - emit_block sym is_global boxedintnat_header - (emit_boxed_nativeint_constant n cont) + emit_nativeint_constant symb n cont | Uconst_block (tag, csts) -> let cont = List.fold_right emit_constant csts cont in - emit_block sym is_global (block_header tag (List.length csts)) cont + emit_block symb (block_header tag (List.length csts)) cont | Uconst_float_array fields -> - emit_block sym is_global (floatarray_header (List.length fields)) - (Misc.map_end (fun f -> Cdouble f) fields cont) + emit_float_array_constant symb fields cont | Uconst_closure(fundecls, lbl, fv) -> Cmmgen_state.add_constant lbl (Const_closure (is_global, fundecls, fv)); List.iter (fun f -> Cmmgen_state.add_function f) fundecls; cont -and emit_constant cst cont = - match cst with - | Uconst_int n | Uconst_ptr n -> - cint_const n - :: cont - | Uconst_ref (sym, _) -> - Csymbol_address sym :: cont - -and emit_string_constant s cont = - let n = size_int - 1 - (String.length s) mod size_int in - Cstring s :: Cskip n :: Cint8 n :: cont - -and emit_boxed_int32_constant n cont = - let n = Nativeint.of_int32 n in - if size_int = 8 then - Csymbol_address caml_int32_ops :: Cint32 n :: Cint32 0n :: cont - else - Csymbol_address caml_int32_ops :: Cint n :: cont - -and emit_boxed_nativeint_constant n cont = - Csymbol_address caml_nativeint_ops :: Cint n :: cont - -and emit_boxed_int64_constant n cont = - let lo = Int64.to_nativeint n in - if size_int = 8 then - Csymbol_address caml_int64_ops :: Cint lo :: cont - else begin - let hi = Int64.to_nativeint (Int64.shift_right n 32) in - if big_endian then - Csymbol_address caml_int64_ops :: Cint hi :: Cint lo :: cont - else - Csymbol_address caml_int64_ops :: Cint lo :: Cint hi :: cont - end - (* Boxed integers *) let box_int_constant sym bi n = match bi with Pnativeint -> - emit_block sym Local boxedintnat_header - (emit_boxed_nativeint_constant n []) + emit_nativeint_constant (sym, Local) n [] | Pint32 -> let n = Nativeint.to_int32 n in - emit_block sym Local boxedint32_header - (emit_boxed_int32_constant n []) + emit_int32_constant (sym, Local) n [] | Pint64 -> let n = Int64.of_nativeint n in - emit_block sym Local boxedint64_header - (emit_boxed_int64_constant n []) - -let operations_boxed_int bi = - match bi with - Pnativeint -> caml_nativeint_ops - | Pint32 -> caml_int32_ops - | Pint64 -> caml_int64_ops - -let alloc_header_boxed_int bi = - match bi with - Pnativeint -> alloc_boxedintnat_header - | Pint32 -> alloc_boxedint32_header - | Pint64 -> alloc_boxedint64_header + emit_int64_constant (sym, Local) n [] let box_int dbg bi arg = match arg with @@ -1108,95 +243,7 @@ let box_int dbg bi arg = Cmmgen_state.add_data_items data_items; Cconst_symbol (sym, dbg) | _ -> - let arg' = - if bi = Pint32 && size_int = 8 && big_endian - then Cop(Clsl, [arg; Cconst_int (32, dbg)], dbg) - else arg in - Cop(Calloc, [alloc_header_boxed_int bi dbg; - Cconst_symbol(operations_boxed_int bi, dbg); - arg'], dbg) - -let split_int64_for_32bit_target arg dbg = - bind "split_int64" arg (fun arg -> - let first = Cop (Cadda, [Cconst_int (size_int, dbg); arg], dbg) in - let second = Cop (Cadda, [Cconst_int (2 * size_int, dbg); arg], dbg) in - Ctuple [Cop (Cload (Thirtytwo_unsigned, Mutable), [first], dbg); - Cop (Cload (Thirtytwo_unsigned, Mutable), [second], dbg)]) - -let alloc_matches_boxed_int bi ~hdr ~ops = - match bi, hdr, ops with - | Pnativeint, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) -> - Nativeint.equal hdr boxedintnat_header - && String.equal sym caml_nativeint_ops - | Pint32, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) -> - Nativeint.equal hdr boxedint32_header - && String.equal sym caml_int32_ops - | Pint64, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) -> - Nativeint.equal hdr boxedint64_header - && String.equal sym caml_int64_ops - | (Pnativeint | Pint32 | Pint64), _, _ -> false - -let unbox_int dbg bi = - let default arg = - if size_int = 4 && bi = Pint64 then - split_int64_for_32bit_target arg dbg - else - Cop( - Cload((if bi = Pint32 then Thirtytwo_signed else Word_int), - Immutable), - [Cop(Cadda, [arg; Cconst_int (size_addr, dbg)], dbg)], dbg) - in - map_tail - (function - | Cop(Calloc, - [hdr; ops; - Cop(Clsl, [contents; Cconst_int (32, _)], dbg')], _dbg) - when bi = Pint32 && size_int = 8 && big_endian - && alloc_matches_boxed_int bi ~hdr ~ops -> - (* Force sign-extension of low 32 bits *) - Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg'); - Cconst_int (32, dbg)], - dbg) - | Cop(Calloc, - [hdr; ops; contents], _dbg) - when bi = Pint32 && size_int = 8 && not big_endian - && alloc_matches_boxed_int bi ~hdr ~ops -> - (* Force sign-extension of low 32 bits *) - Cop(Casr, [Cop(Clsl, [contents; Cconst_int (32, dbg)], dbg); - Cconst_int (32, dbg)], - dbg) - | Cop(Calloc, [hdr; ops; contents], _dbg) - when alloc_matches_boxed_int bi ~hdr ~ops -> - contents - | Cconst_symbol (s, _dbg) as cmm -> - begin match structured_constant_of_sym s, bi with - | Some (Uconst_nativeint n), Pnativeint -> - Cconst_natint (n, dbg) - | Some (Uconst_int32 n), Pint32 -> - Cconst_natint (Nativeint.of_int32 n, dbg) - | Some (Uconst_int64 n), Pint64 -> - if size_int = 8 then - Cconst_natint (Int64.to_nativeint n, dbg) - else - let low = Int64.to_nativeint n in - let high = - Int64.to_nativeint (Int64.shift_right_logical n 32) - in - if big_endian then - Ctuple [Cconst_natint (high, dbg); Cconst_natint (low, dbg)] - else - Ctuple [Cconst_natint (low, dbg); Cconst_natint (high, dbg)] - | _ -> - default cmm - end - | cmm -> - default cmm - ) - -let make_unsigned_int bi arg dbg = - if bi = Pint32 && size_int = 8 - then Cop(Cand, [arg; Cconst_natint (0xFFFFFFFFn, dbg)], dbg) - else arg + box_int_gen dbg bi arg (* Boxed numbers *) @@ -1224,668 +271,6 @@ let unbox_number dbg bn arg = | Boxed_float _ -> unbox_float dbg arg | Boxed_integer (bi, _) -> unbox_int dbg bi arg -(* Big arrays *) - -let bigarray_elt_size = function - Pbigarray_unknown -> assert false - | Pbigarray_float32 -> 4 - | Pbigarray_float64 -> 8 - | Pbigarray_sint8 -> 1 - | Pbigarray_uint8 -> 1 - | Pbigarray_sint16 -> 2 - | Pbigarray_uint16 -> 2 - | Pbigarray_int32 -> 4 - | Pbigarray_int64 -> 8 - | Pbigarray_caml_int -> size_int - | Pbigarray_native_int -> size_int - | Pbigarray_complex32 -> 8 - | Pbigarray_complex64 -> 16 - -(* Produces a pointer to the element of the bigarray [b] on the position - [args]. [args] is given as a list of tagged int expressions, one per array - dimension. *) -let bigarray_indexing unsafe elt_kind layout b args dbg = - let check_ba_bound bound idx v = - Csequence(make_checkbound dbg [bound;idx], v) in - (* Validates the given multidimensional offset against the array bounds and - transforms it into a one dimensional offset. The offsets are expressions - evaluating to tagged int. *) - let rec ba_indexing dim_ofs delta_ofs = function - [] -> assert false - | [arg] -> - if unsafe then arg - else - bind "idx" arg (fun idx -> - (* Load the untagged int bound for the given dimension *) - let bound = - Cop(Cload (Word_int, Mutable),[field_address b dim_ofs dbg], dbg) - in - let idxn = untag_int idx dbg in - check_ba_bound bound idxn idx) - | arg1 :: argl -> - (* The remainder of the list is transformed into a one dimensional offset - *) - let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in - (* Load the untagged int bound for the given dimension *) - let bound = - Cop(Cload (Word_int, Mutable), [field_address b dim_ofs dbg], dbg) - in - if unsafe then add_int (mul_int (decr_int rem dbg) bound dbg) arg1 dbg - else - bind "idx" arg1 (fun idx -> - bind "bound" bound (fun bound -> - let idxn = untag_int idx dbg in - (* [offset = rem * (tag_int bound) + idx] *) - let offset = - add_int (mul_int (decr_int rem dbg) bound dbg) idx dbg - in - check_ba_bound bound idxn offset)) in - (* The offset as an expression evaluating to int *) - let offset = - match layout with - Pbigarray_unknown_layout -> - assert false - | Pbigarray_c_layout -> - ba_indexing (4 + List.length args) (-1) (List.rev args) - | Pbigarray_fortran_layout -> - ba_indexing 5 1 - (List.map (fun idx -> sub_int idx (Cconst_int (2, dbg)) dbg) args) - and elt_size = - bigarray_elt_size elt_kind in - (* [array_indexing] can simplify the given expressions *) - array_indexing ~typ:Addr (log2 elt_size) - (Cop(Cload (Word_int, Mutable), - [field_address b 1 dbg], dbg)) offset dbg - -let bigarray_word_kind = function - Pbigarray_unknown -> assert false - | Pbigarray_float32 -> Single - | Pbigarray_float64 -> Double - | Pbigarray_sint8 -> Byte_signed - | Pbigarray_uint8 -> Byte_unsigned - | Pbigarray_sint16 -> Sixteen_signed - | Pbigarray_uint16 -> Sixteen_unsigned - | Pbigarray_int32 -> Thirtytwo_signed - | Pbigarray_int64 -> Word_int - | Pbigarray_caml_int -> Word_int - | Pbigarray_native_int -> Word_int - | Pbigarray_complex32 -> Single - | Pbigarray_complex64 -> Double - -let bigarray_get unsafe elt_kind layout b args dbg = - bind "ba" b (fun b -> - match elt_kind with - Pbigarray_complex32 | Pbigarray_complex64 -> - let kind = bigarray_word_kind elt_kind in - let sz = bigarray_elt_size elt_kind / 2 in - bind "addr" - (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> - bind "reval" - (Cop(Cload (kind, Mutable), [addr], dbg)) (fun reval -> - bind "imval" - (Cop(Cload (kind, Mutable), - [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg)], dbg)) - (fun imval -> box_complex dbg reval imval))) - | _ -> - Cop(Cload (bigarray_word_kind elt_kind, Mutable), - [bigarray_indexing unsafe elt_kind layout b args dbg], - dbg)) - -let bigarray_set unsafe elt_kind layout b args newval dbg = - bind "ba" b (fun b -> - match elt_kind with - Pbigarray_complex32 | Pbigarray_complex64 -> - let kind = bigarray_word_kind elt_kind in - let sz = bigarray_elt_size elt_kind / 2 in - bind "newval" newval (fun newv -> - bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) - (fun addr -> - Csequence( - Cop(Cstore (kind, Assignment), [addr; complex_re newv dbg], dbg), - Cop(Cstore (kind, Assignment), - [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg); - complex_im newv dbg], - dbg)))) - | _ -> - Cop(Cstore (bigarray_word_kind elt_kind, Assignment), - [bigarray_indexing unsafe elt_kind layout b args dbg; newval], - dbg)) - -let unaligned_load_16 ptr idx dbg = - if Arch.allow_unaligned_access - then Cop(Cload (Sixteen_unsigned, Mutable), [add_int ptr idx dbg], dbg) - else - let cconst_int i = Cconst_int (i, dbg) in - let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in - let v2 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) - in - let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in - Cop(Cor, [lsl_int b1 (cconst_int 8) dbg; b2], dbg) - -let unaligned_set_16 ptr idx newval dbg = - if Arch.allow_unaligned_access - then - Cop(Cstore (Sixteen_unsigned, Assignment), - [add_int ptr idx dbg; newval], dbg) - else - let cconst_int i = Cconst_int (i, dbg) in - let v1 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); - cconst_int 0xFF], dbg) - in - let v2 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in - let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in - Csequence( - Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg), - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], dbg)) - -let unaligned_load_32 ptr idx dbg = - if Arch.allow_unaligned_access - then Cop(Cload (Thirtytwo_unsigned, Mutable), [add_int ptr idx dbg], dbg) - else - let cconst_int i = Cconst_int (i, dbg) in - let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in - let v2 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) - in - let v3 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 2) dbg], dbg) - in - let v4 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 3) dbg], dbg) - in - let b1, b2, b3, b4 = - if Arch.big_endian - then v1, v2, v3, v4 - else v4, v3, v2, v1 in - Cop(Cor, - [Cop(Cor, [lsl_int b1 (cconst_int 24) dbg; - lsl_int b2 (cconst_int 16) dbg], dbg); - Cop(Cor, [lsl_int b3 (cconst_int 8) dbg; b4], dbg)], - dbg) - -let unaligned_set_32 ptr idx newval dbg = - if Arch.allow_unaligned_access - then - Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx dbg; newval], - dbg) - else - let cconst_int i = Cconst_int (i, dbg) in - let v1 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int 24], dbg); cconst_int 0xFF], dbg) - in - let v2 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int 16], dbg); cconst_int 0xFF], dbg) - in - let v3 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); cconst_int 0xFF], dbg) - in - let v4 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in - let b1, b2, b3, b4 = - if Arch.big_endian - then v1, v2, v3, v4 - else v4, v3, v2, v1 in - Csequence( - Csequence( - Cop(Cstore (Byte_unsigned, Assignment), - [add_int ptr idx dbg; b1], dbg), - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], - dbg)), - Csequence( - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3], - dbg), - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4], - dbg))) - -let unaligned_load_64 ptr idx dbg = - assert(size_int = 8); - if Arch.allow_unaligned_access - then Cop(Cload (Word_int, Mutable), [add_int ptr idx dbg], dbg) - else - let cconst_int i = Cconst_int (i, dbg) in - let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in - let v2 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) - in - let v3 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 2) dbg], dbg) - in - let v4 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 3) dbg], dbg) - in - let v5 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 4) dbg], dbg) - in - let v6 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 5) dbg], dbg) - in - let v7 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 6) dbg], dbg) - in - let v8 = Cop(Cload (Byte_unsigned, Mutable), - [add_int (add_int ptr idx dbg) (cconst_int 7) dbg], dbg) - in - let b1, b2, b3, b4, b5, b6, b7, b8 = - if Arch.big_endian - then v1, v2, v3, v4, v5, v6, v7, v8 - else v8, v7, v6, v5, v4, v3, v2, v1 in - Cop(Cor, - [Cop(Cor, - [Cop(Cor, [lsl_int b1 (cconst_int (8*7)) dbg; - lsl_int b2 (cconst_int (8*6)) dbg], dbg); - Cop(Cor, [lsl_int b3 (cconst_int (8*5)) dbg; - lsl_int b4 (cconst_int (8*4)) dbg], dbg)], - dbg); - Cop(Cor, - [Cop(Cor, [lsl_int b5 (cconst_int (8*3)) dbg; - lsl_int b6 (cconst_int (8*2)) dbg], dbg); - Cop(Cor, [lsl_int b7 (cconst_int 8) dbg; - b8], dbg)], - dbg)], dbg) - -let unaligned_set_64 ptr idx newval dbg = - assert(size_int = 8); - if Arch.allow_unaligned_access - then Cop(Cstore (Word_int, Assignment), [add_int ptr idx dbg; newval], dbg) - else - let cconst_int i = Cconst_int (i, dbg) in - let v1 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*7)], dbg); cconst_int 0xFF], - dbg) - in - let v2 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*6)], dbg); cconst_int 0xFF], - dbg) - in - let v3 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*5)], dbg); cconst_int 0xFF], - dbg) - in - let v4 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*4)], dbg); cconst_int 0xFF], - dbg) - in - let v5 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*3)], dbg); cconst_int 0xFF], - dbg) - in - let v6 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*2)], dbg); cconst_int 0xFF], - dbg) - in - let v7 = - Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); cconst_int 0xFF], - dbg) - in - let v8 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in - let b1, b2, b3, b4, b5, b6, b7, b8 = - if Arch.big_endian - then v1, v2, v3, v4, v5, v6, v7, v8 - else v8, v7, v6, v5, v4, v3, v2, v1 in - Csequence( - Csequence( - Csequence( - Cop(Cstore (Byte_unsigned, Assignment), - [add_int ptr idx dbg; b1], - dbg), - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], - dbg)), - Csequence( - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3], - dbg), - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4], - dbg))), - Csequence( - Csequence( - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 4) dbg; b5], - dbg), - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 5) dbg; b6], - dbg)), - Csequence( - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 6) dbg; b7], - dbg), - Cop(Cstore (Byte_unsigned, Assignment), - [add_int (add_int ptr idx dbg) (cconst_int 7) dbg; b8], - dbg)))) - -let max_or_zero a dbg = - bind "size" a (fun a -> - (* equivalent to - Cifthenelse(Cop(Ccmpi Cle, [a; cconst_int 0]), cconst_int 0, a) - - if a is positive, sign is 0 hence sign_negation is full of 1 - so sign_negation&a = a - if a is negative, sign is full of 1 hence sign_negation is 0 - so sign_negation&a = 0 *) - let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1, dbg)], dbg) in - let sign_negation = Cop(Cxor, [sign; Cconst_int (-1, dbg)], dbg) in - Cop(Cand, [sign_negation; a], dbg)) - -let check_bound safety access_size dbg length a2 k = - match safety with - | Unsafe -> k - | Safe -> - let offset = - match access_size with - | Sixteen -> 1 - | Thirty_two -> 3 - | Sixty_four -> 7 - in - let a1 = - sub_int length (Cconst_int (offset, dbg)) dbg - in - Csequence(make_checkbound dbg [max_or_zero a1 dbg; a2], k) - -let unaligned_set size ptr idx newval dbg = - match size with - | Sixteen -> unaligned_set_16 ptr idx newval dbg - | Thirty_two -> unaligned_set_32 ptr idx newval dbg - | Sixty_four -> unaligned_set_64 ptr idx newval dbg - -let unaligned_load size ptr idx dbg = - match size with - | Sixteen -> unaligned_load_16 ptr idx dbg - | Thirty_two -> unaligned_load_32 ptr idx dbg - | Sixty_four -> unaligned_load_64 ptr idx dbg - -let box_sized size dbg exp = - match size with - | Sixteen -> tag_int exp dbg - | Thirty_two -> box_int dbg Pint32 exp - | Sixty_four -> box_int dbg Pint64 exp - -(* Simplification of some primitives into C calls *) - -let default_prim name = - Primitive.simple ~name ~arity:0(*ignored*) ~alloc:true - -let int64_native_prim name arity ~alloc = - let u64 = Unboxed_integer Pint64 in - let rec make_args = function 0 -> [] | n -> u64 :: make_args (n - 1) in - Primitive.make ~name ~native_name:(name ^ "_native") - ~alloc - ~native_repr_args:(make_args arity) - ~native_repr_res:u64 - -let simplif_primitive_32bits = function - Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int") - | Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int") - | Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32") - | Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32") - | Pcvtbint(Pnativeint, Pint64) -> - Pccall (default_prim "caml_int64_of_nativeint") - | Pcvtbint(Pint64, Pnativeint) -> - Pccall (default_prim "caml_int64_to_nativeint") - | Pnegbint Pint64 -> Pccall (int64_native_prim "caml_int64_neg" 1 - ~alloc:false) - | Paddbint Pint64 -> Pccall (int64_native_prim "caml_int64_add" 2 - ~alloc:false) - | Psubbint Pint64 -> Pccall (int64_native_prim "caml_int64_sub" 2 - ~alloc:false) - | Pmulbint Pint64 -> Pccall (int64_native_prim "caml_int64_mul" 2 - ~alloc:false) - | Pdivbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_div" 2 - ~alloc:true) - | Pmodbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_mod" 2 - ~alloc:true) - | Pandbint Pint64 -> Pccall (int64_native_prim "caml_int64_and" 2 - ~alloc:false) - | Porbint Pint64 -> Pccall (int64_native_prim "caml_int64_or" 2 - ~alloc:false) - | Pxorbint Pint64 -> Pccall (int64_native_prim "caml_int64_xor" 2 - ~alloc:false) - | Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left") - | Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned") - | Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right") - | Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal") - | Pbintcomp(Pint64, Lambda.Cne) -> Pccall (default_prim "caml_notequal") - | Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan") - | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") - | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") - | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") - | Pbigarrayref(_unsafe, n, Pbigarray_int64, _layout) -> - Pccall (default_prim ("caml_ba_get_" ^ Int.to_string n)) - | Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) -> - Pccall (default_prim ("caml_ba_set_" ^ Int.to_string n)) - | Pstring_load(Sixty_four, _) -> Pccall (default_prim "caml_string_get64") - | Pbytes_load(Sixty_four, _) -> Pccall (default_prim "caml_bytes_get64") - | Pbytes_set(Sixty_four, _) -> Pccall (default_prim "caml_bytes_set64") - | Pbigstring_load(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_get64") - | Pbigstring_set(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_set64") - | Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap") - | p -> p - -let simplif_primitive p = - match p with - | Pduprecord _ -> - Pccall (default_prim "caml_obj_dup") - | Pbigarrayref(_unsafe, n, Pbigarray_unknown, _layout) -> - Pccall (default_prim ("caml_ba_get_" ^ Int.to_string n)) - | Pbigarrayset(_unsafe, n, Pbigarray_unknown, _layout) -> - Pccall (default_prim ("caml_ba_set_" ^ Int.to_string n)) - | Pbigarrayref(_unsafe, n, _kind, Pbigarray_unknown_layout) -> - Pccall (default_prim ("caml_ba_get_" ^ Int.to_string n)) - | Pbigarrayset(_unsafe, n, _kind, Pbigarray_unknown_layout) -> - Pccall (default_prim ("caml_ba_set_" ^ Int.to_string n)) - | p -> - if size_int = 8 then p else simplif_primitive_32bits p - -(* Build switchers both for constants and blocks *) - -let transl_isout h arg dbg = tag_int (Cop(Ccmpa Clt, [h ; arg], dbg)) dbg - -(* Build an actual switch (ie jump table) *) - -let make_switch arg cases actions dbg = - let extract_uconstant = - function - (* Constant integers loaded from a table should end in 1, - so that Cload never produces untagged integers *) - | Cconst_int (n, _), _dbg - | Cconst_pointer (n, _), _dbg when (n land 1) = 1 -> - Some (Cint (Nativeint.of_int n)) - | Cconst_natint (n, _), _dbg - | Cconst_natpointer (n, _), _dbg - when Nativeint.(to_int (logand n one) = 1) -> - Some (Cint n) - | Cconst_symbol (s,_), _dbg -> - Some (Csymbol_address s) - | _ -> None - in - let extract_affine ~cases ~const_actions = - let length = Array.length cases in - if length >= 2 - then begin - match const_actions.(cases.(0)), const_actions.(cases.(1)) with - | Cint v0, Cint v1 -> - let slope = Nativeint.sub v1 v0 in - let check i = function - | Cint v -> v = Nativeint.(add (mul (of_int i) slope) v0) - | _ -> false - in - if Misc.Stdlib.Array.for_alli - (fun i idx -> check i const_actions.(idx)) cases - then Some (v0, slope) - else None - | _, _ -> - None - end - else None - in - let make_table_lookup ~cases ~const_actions arg dbg = - let table = Compilenv.new_const_symbol () in - Cmmgen_state.add_constant table (Const_table (Local, - Array.to_list (Array.map (fun act -> - const_actions.(act)) cases))); - addr_array_ref (Cconst_symbol (table, dbg)) (tag_int arg dbg) dbg - in - let make_affine_computation ~offset ~slope arg dbg = - (* In case the resulting integers are an affine function of the index, we - don't emit a table, and just compute the result directly *) - add_int - (mul_int arg (natint_const_untagged dbg slope) dbg) - (natint_const_untagged dbg offset) - dbg - in - match Misc.Stdlib.Array.all_somes (Array.map extract_uconstant actions) with - | None -> - Cswitch (arg,cases,actions,dbg) - | Some const_actions -> - match extract_affine ~cases ~const_actions with - | Some (offset, slope) -> - make_affine_computation ~offset ~slope arg dbg - | None -> make_table_lookup ~cases ~const_actions arg dbg - -module SArgBlocks = -struct - type primitive = operation - - let eqint = Ccmpi Ceq - let neint = Ccmpi Cne - let leint = Ccmpi Cle - let ltint = Ccmpi Clt - let geint = Ccmpi Cge - let gtint = Ccmpi Cgt - - type act = expression - - (* CR mshinwell: GPR#2294 will fix the Debuginfo here *) - - let make_const i = Cconst_int (i, Debuginfo.none) - let make_prim p args = Cop (p,args, Debuginfo.none) - let make_offset arg n = add_const arg n Debuginfo.none - let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none) - let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none) - let make_if cond ifso ifnot = - Cifthenelse (cond, Debuginfo.none, ifso, Debuginfo.none, ifnot, - Debuginfo.none) - let make_switch loc arg cases actions = - let dbg = Debuginfo.from_location loc in - let actions = Array.map (fun expr -> expr, dbg) actions in - make_switch arg cases actions dbg - let bind arg body = bind "switcher" arg body - - let make_catch handler = - match handler with - | Cexit (i,[]) -> i,fun e -> e - | _ -> - let dbg = Debuginfo.none in - let i = next_raise_count () in -(* - Printf.eprintf "SHARE CMM: %i\n" i ; - Printcmm.expression Format.str_formatter handler ; - Printf.eprintf "%s\n" (Format.flush_str_formatter ()) ; -*) - i, - (fun body -> match body with - | Cexit (j,_) -> - if i=j then handler - else body - | _ -> ccatch (i,[],body,handler, dbg)) - - let make_exit i = Cexit (i,[]) - -end - -(* cmm store, as sharing as normally been detected in previous - phases, we only share exits *) -(* Some specific patterns can lead to switches where several cases - point to the same action, but this action is not an exit (see GPR#1370). - The addition of the index in the action array as context allows - sharing them correctly without duplication. *) -module StoreExpForSwitch = - Switch.CtxStore - (struct - type t = expression - type key = int option * int - type context = int - let make_key index expr = - let continuation = - match expr with - | Cexit (i,[]) -> Some i - | _ -> None - in - Some (continuation, index) - let compare_key (cont, index) (cont', index') = - match cont, cont' with - | Some i, Some i' when i = i' -> 0 - | _, _ -> Stdlib.compare index index' - end) - -(* For string switches, we can use a generic store *) -module StoreExp = - Switch.Store - (struct - type t = expression - type key = int - let make_key = function - | Cexit (i,[]) -> Some i - | _ -> None - let compare_key = Stdlib.compare - end) - -module SwitcherBlocks = Switch.Make(SArgBlocks) - -(* Int switcher, arg in [low..high], - cases is list of individual cases, and is sorted by first component *) - -let transl_int_switch loc arg low high cases default = match cases with -| [] -> assert false -| _::_ -> - let store = StoreExp.mk_store () in - assert (store.Switch.act_store () default = 0) ; - let cases = - List.map - (fun (i,act) -> i,store.Switch.act_store () act) - cases in - let rec inters plow phigh pact = function - | [] -> - if phigh = high then [plow,phigh,pact] - else [(plow,phigh,pact); (phigh+1,high,0) ] - | (i,act)::rem -> - if i = phigh+1 then - if pact = act then - inters plow i pact rem - else - (plow,phigh,pact)::inters i i act rem - else (* insert default *) - if pact = 0 then - if act = 0 then - inters plow i 0 rem - else - (plow,i-1,pact):: - inters i i act rem - else (* pact <> 0 *) - (plow,phigh,pact):: - begin - if act = 0 then inters (phigh+1) i 0 rem - else (phigh+1,i-1,0)::inters i i act rem - end in - let inters = match cases with - | [] -> assert false - | (k0,act0)::rem -> - if k0 = low then inters k0 k0 act0 rem - else inters low (k0-1) 0 cases in - bind "switcher" arg - (fun a -> - SwitcherBlocks.zyva - loc - (low,high) - a - (Array.of_list inters) store) - - (* Auxiliary functions for optimizing "let" of boxed numbers (floats and boxed integers *) @@ -1942,7 +327,7 @@ let is_unboxed_number_cmm ~strict cmm = else notify No_unboxing | Cconst_symbol (s, _) -> - begin match structured_constant_of_sym s with + begin match Cmmgen_state.structured_constant_of_sym s with | Some (Uconst_float _) -> notify (Boxed (Boxed_float Debuginfo.none, true)) | Some (Uconst_nativeint _) -> @@ -1961,29 +346,8 @@ let is_unboxed_number_cmm ~strict cmm = aux cmm; !r -(* Helper for compilation of initialization and assignment operations *) - -type assignment_kind = Caml_modify | Caml_initialize | Simple - -let assignment_kind ptr init = - match init, ptr with - | Assignment, Pointer -> Caml_modify - | Heap_initialization, Pointer -> Caml_initialize - | Assignment, Immediate - | Heap_initialization, Immediate - | Root_initialization, (Immediate | Pointer) -> Simple - (* Translate an expression *) -let strmatch_compile = - let module S = - Strmatch.Make - (struct - let string_block_length ptr = get_size ptr Debuginfo.none - let transl_switch = transl_int_switch - end) in - S.compile - let rec transl env e = match e with Uvar id -> @@ -2016,7 +380,7 @@ let rec transl env e = int_const dbg f.arity :: transl_fundecls (pos + 3) rem else - Cconst_symbol (curry_function f.arity, dbg) :: + Cconst_symbol (curry_function_sym f.arity, dbg) :: int_const dbg f.arity :: Cconst_symbol (f.label, dbg) :: transl_fundecls (pos + 4) rem @@ -2034,46 +398,19 @@ let rec transl env e = (* produces a valid Caml value, pointing just after an infix header *) let ptr = transl env arg in let dbg = Debuginfo.none in - if offset = 0 - then ptr - else Cop(Caddv, [ptr; Cconst_int(offset * size_addr, dbg)], dbg) + ptr_offset ptr offset dbg | Udirect_apply(lbl, args, dbg) -> - Cop(Capply typ_val, - Cconst_symbol (lbl, dbg) :: List.map (transl env) args, - dbg) - | Ugeneric_apply(clos, [arg], dbg) -> - bind "fun" (transl env clos) (fun clos -> - Cop(Capply typ_val, - [get_field env clos 0 dbg; transl env arg; clos], - dbg)) + let args = List.map (transl env) args in + direct_apply lbl args dbg | Ugeneric_apply(clos, args, dbg) -> - let arity = List.length args in - let cargs = Cconst_symbol(apply_function arity, dbg) :: - List.map (transl env) (args @ [clos]) in - Cop(Capply typ_val, cargs, dbg) + let clos = transl env clos in + let args = List.map (transl env) args in + generic_apply (mut_from_env env clos) clos args dbg | Usend(kind, met, obj, args, dbg) -> - let call_met obj args clos = - if args = [] then - Cop(Capply typ_val, - [get_field env clos 0 dbg; obj; clos], dbg) - else - let arity = List.length args + 1 in - let cargs = Cconst_symbol(apply_function arity, dbg) :: obj :: - (List.map (transl env) args) @ [clos] in - Cop(Capply typ_val, cargs, dbg) - in - bind "obj" (transl env obj) (fun obj -> - match kind, args with - Self, _ -> - bind "met" (lookup_label obj (transl env met) dbg) - (call_met obj args) - | Cached, cache :: pos :: args -> - call_cached_method obj - (transl env met) (transl env cache) (transl env pos) - (List.map (transl env) args) dbg - | _ -> - bind "met" (lookup_tag obj (transl env met) dbg) - (call_met obj args)) + let met = transl env met in + let obj = transl env obj in + let args = List.map (transl env) args in + send kind met obj args dbg | Ulet(str, kind, id, exp, body) -> transl_let env str kind id exp body | Uphantom_let (var, defining_expr, body) -> @@ -2428,36 +765,19 @@ and transl_prim_1 env p arg dbg = get_field env (transl env arg) n dbg | Pfloatfield n -> let ptr = transl env arg in - box_float dbg ( - Cop(Cload (Double_u, Mutable), - [if n = 0 - then ptr - else Cop(Cadda, [ptr; Cconst_int(n * size_float, dbg)], dbg)], - dbg)) + box_float dbg (floatfield n ptr dbg) | Pint_as_pointer -> - Cop(Caddi, [transl env arg; Cconst_int (-1, dbg)], dbg) - (* always a pointer outside the heap *) + int_as_pointer (transl env arg) dbg (* Exceptions *) - | Praise _ when not (!Clflags.debug) -> - Cop(Craise Lambda.Raise_notrace, [transl env arg], dbg) - | Praise raise_kind -> - Cop(Craise raise_kind, [transl env arg], dbg) + | Praise rkind -> + raise_prim rkind (transl env arg) dbg (* Integer operations *) | Pnegint -> - Cop(Csubi, [Cconst_int (2, dbg); transl env arg], dbg) + negint (transl env arg) dbg | Poffsetint n -> - if no_overflow_lsl n 1 then - add_const (transl env arg) (n lsl 1) dbg - else - transl_prim_2 env Paddint arg (Uconst (Uconst_int n)) dbg + offsetint n (transl env arg) dbg | Poffsetref n -> - return_unit dbg - (bind "ref" (transl env arg) (fun arg -> - Cop(Cstore (Word_int, Assignment), - [arg; - add_const (Cop(Cload (Word_int, Mutable), [arg], dbg)) - (n lsl 1) dbg], - dbg))) + offsetref n (transl env arg) dbg (* Floating-point operations *) | Pfloatofint -> box_float dbg (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg)) @@ -2472,29 +792,7 @@ and transl_prim_1 env p arg dbg = tag_int(string_length (transl env arg) dbg) dbg (* Array operations *) | Parraylength kind -> - let hdr = get_header_without_profinfo (transl env arg) dbg in - begin match kind with - Pgenarray -> - let len = - if wordsize_shift = numfloat_shift then - Cop(Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg) - else - bind "header" hdr (fun hdr -> - Cifthenelse(is_addr_array_hdr hdr dbg, - dbg, - Cop(Clsr, - [hdr; Cconst_int (wordsize_shift, dbg)], dbg), - dbg, - Cop(Clsr, - [hdr; Cconst_int (numfloat_shift, dbg)], dbg), - dbg)) - in - Cop(Cor, [len; Cconst_int (1, dbg)], dbg) - | Paddrarray | Pintarray -> - Cop(Cor, [addr_array_length hdr dbg; Cconst_int (1, dbg)], dbg) - | Pfloatarray -> - Cop(Cor, [float_array_length hdr dbg; Cconst_int (1, dbg)], dbg) - end + arraylength kind (transl env arg) dbg (* Boolean operations *) | Pnot -> transl_if env Then_false_else_true @@ -2516,19 +814,9 @@ and transl_prim_1 env p arg dbg = (Cop(Csubi, [Cconst_int (0, dbg); transl_unbox_int dbg env bi arg], dbg)) | Pbbswap bi -> - let prim = match bi with - | Pnativeint -> "nativeint" - | Pint32 -> "int32" - | Pint64 -> "int64" in - box_int dbg bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim, - typ_int, false, None), - [transl_unbox_int dbg env bi arg], - dbg)) + box_int dbg bi (bbswap bi (transl_unbox_int dbg env bi arg) dbg) | Pbswap16 -> - tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, None), - [untag_int (transl env arg) dbg], - dbg)) - dbg + tag_int (bswap16 (untag_int (transl env arg) dbg) dbg) dbg | (Pfield_computed | Psequand | Psequor | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint @@ -2555,29 +843,11 @@ and transl_prim_2 env p arg1 arg2 dbg = | Pfield_computed -> addr_array_ref (transl env arg1) (transl env arg2) dbg | Psetfield(n, ptr, init) -> - begin match assignment_kind ptr init with - | Caml_modify -> - return_unit dbg (Cop(Cextcall("caml_modify", typ_void, false, None), - [field_address (transl env arg1) n dbg; - transl env arg2], - dbg)) - | Caml_initialize -> - return_unit dbg (Cop(Cextcall("caml_initialize", typ_void, false, None), - [field_address (transl env arg1) n dbg; - transl env arg2], - dbg)) - | Simple -> - return_unit dbg - (set_field (transl env arg1) n (transl env arg2) init dbg) - end + setfield n ptr init (transl env arg1) (transl env arg2) dbg | Psetfloatfield (n, init) -> let ptr = transl env arg1 in - return_unit dbg ( - Cop(Cstore (Double_u, init), - [if n = 0 then ptr - else - Cop(Cadda, [ptr; Cconst_int(n * size_float, dbg)], dbg); - transl_unbox_float dbg env arg2], dbg)) + let float_val = transl_unbox_float dbg env arg2 in + setfloatfield n init ptr float_val dbg (* Boolean operations *) | Psequand -> @@ -2599,50 +869,29 @@ and transl_prim_2 env p arg1 arg2 dbg = dbg' (Cconst_pointer (1, dbg)) (* Integer operations *) | Paddint -> - decr_int(add_int (transl env arg1) (transl env arg2) dbg) dbg + add_int_caml (transl env arg1) (transl env arg2) dbg | Psubint -> - incr_int(sub_int (transl env arg1) (transl env arg2) dbg) dbg + sub_int_caml (transl env arg1) (transl env arg2) dbg | Pmulint -> - begin - (* decrementing the non-constant part helps when the multiplication is - followed by an addition; - for example, using this trick compiles (100 * a + 7) into - (+ ( * a 100) -85) - rather than - (+ ( * 200 (>>s a 1)) 15) - *) - match transl env arg1, transl env arg2 with - | Cconst_int _ as c1, c2 -> - incr_int (mul_int (untag_int c1 dbg) (decr_int c2 dbg) dbg) dbg - | c1, c2 -> - incr_int (mul_int (decr_int c1 dbg) (untag_int c2 dbg) dbg) dbg - end + mul_int_caml (transl env arg1) (transl env arg2) dbg | Pdivint is_safe -> - tag_int(div_int (untag_int(transl env arg1) dbg) - (untag_int(transl env arg2) dbg) is_safe dbg) dbg + div_int_caml is_safe (transl env arg1) (transl env arg2) dbg | Pmodint is_safe -> - tag_int(mod_int (untag_int(transl env arg1) dbg) - (untag_int(transl env arg2) dbg) is_safe dbg) dbg + mod_int_caml is_safe (transl env arg1) (transl env arg2) dbg | Pandint -> - Cop(Cand, [transl env arg1; transl env arg2], dbg) + and_int_caml (transl env arg1) (transl env arg2) dbg | Porint -> - Cop(Cor, [transl env arg1; transl env arg2], dbg) + or_int_caml (transl env arg1) (transl env arg2) dbg | Pxorint -> - Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl env arg1); - ignore_low_bit_int(transl env arg2)], dbg); - Cconst_int (1, dbg)], dbg) + xor_int_caml (transl env arg1) (transl env arg2) dbg | Plslint -> - incr_int(lsl_int (decr_int(transl env arg1) dbg) - (untag_int(transl env arg2) dbg) dbg) dbg + lsl_int_caml (transl env arg1) (transl env arg2) dbg | Plsrint -> - Cop(Cor, [lsr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg; - Cconst_int (1, dbg)], dbg) + lsr_int_caml (transl env arg1) (transl env arg2) dbg | Pasrint -> - Cop(Cor, [asr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg; - Cconst_int (1, dbg)], dbg) + asr_int_caml (transl env arg1) (transl env arg2) dbg | Pintcomp cmp -> - tag_int(Cop(Ccmpi(transl_int_comparison cmp), - [transl env arg1; transl env arg2], dbg)) dbg + int_comp_caml cmp (transl env arg1) (transl env arg2) dbg | Pisout -> transl_isout (transl env arg1) (transl env arg2) dbg (* Float operations *) @@ -2667,110 +916,26 @@ and transl_prim_2 env p arg1 arg2 dbg = transl_unbox_float dbg env arg2], dbg)) | Pfloatcomp cmp -> - tag_int(Cop(Ccmpf(transl_float_comparison cmp), + tag_int(Cop(Ccmpf cmp, [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], dbg)) dbg (* String operations *) | Pstringrefu | Pbytesrefu -> - tag_int(Cop(Cload (Byte_unsigned, Mutable), - [add_int (transl env arg1) (untag_int(transl env arg2) dbg) - dbg], - dbg)) dbg + stringref_unsafe (transl env arg1) (transl env arg2) dbg | Pstringrefs | Pbytesrefs -> - tag_int - (bind "str" (transl env arg1) (fun str -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - Csequence( - make_checkbound dbg [string_length str dbg; idx], - Cop(Cload (Byte_unsigned, Mutable), - [add_int str idx dbg], dbg))))) dbg - + stringref_safe (transl env arg1) (transl env arg2) dbg | Pstring_load(size, unsafe) | Pbytes_load(size, unsafe) -> - box_sized size dbg - (bind "str" (transl env arg1) (fun str -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - check_bound unsafe size dbg - (string_length str dbg) - idx (unaligned_load size str idx dbg)))) - + string_load size unsafe (transl env arg1) (transl env arg2) dbg | Pbigstring_load(size, unsafe) -> - box_sized size dbg - (bind "ba" (transl env arg1) (fun ba -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "ba_data" - (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) - (fun ba_data -> - check_bound unsafe size dbg - (bigstring_length ba dbg) - idx - (unaligned_load size ba_data idx dbg))))) + bigstring_load size unsafe (transl env arg1) (transl env arg2) dbg (* Array operations *) | Parrayrefu kind -> - begin match kind with - Pgenarray -> - bind "arr" (transl env arg1) (fun arr -> - bind "index" (transl env arg2) (fun idx -> - Cifthenelse(is_addr_array_ptr arr dbg, - dbg, - addr_array_ref arr idx dbg, - dbg, - float_array_ref dbg arr idx, - dbg))) - | Paddrarray -> - addr_array_ref (transl env arg1) (transl env arg2) dbg - | Pintarray -> - (* CR mshinwell: for int/addr_array_ref move "dbg" to first arg *) - int_array_ref (transl env arg1) (transl env arg2) dbg - | Pfloatarray -> - float_array_ref dbg (transl env arg1) (transl env arg2) - end + arrayref_unsafe kind (transl env arg1) (transl env arg2) dbg | Parrayrefs kind -> - begin match kind with - | Pgenarray -> - bind "index" (transl env arg2) (fun idx -> - bind "arr" (transl env arg1) (fun arr -> - bind "header" (get_header_without_profinfo arr dbg) (fun hdr -> - if wordsize_shift = numfloat_shift then - Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], - Cifthenelse(is_addr_array_hdr hdr dbg, - dbg, - addr_array_ref arr idx dbg, - dbg, - float_array_ref dbg arr idx, - dbg)) - else - Cifthenelse(is_addr_array_hdr hdr dbg, - dbg, - Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], - addr_array_ref arr idx dbg), - dbg, - Csequence(make_checkbound dbg [float_array_length hdr dbg; idx], - float_array_ref dbg arr idx), - dbg)))) - | Paddrarray -> - bind "index" (transl env arg2) (fun idx -> - bind "arr" (transl env arg1) (fun arr -> - Csequence(make_checkbound dbg [ - addr_array_length(get_header_without_profinfo arr dbg) dbg; idx], - addr_array_ref arr idx dbg))) - | Pintarray -> - bind "index" (transl env arg2) (fun idx -> - bind "arr" (transl env arg1) (fun arr -> - Csequence(make_checkbound dbg [ - addr_array_length(get_header_without_profinfo arr dbg) dbg; idx], - int_array_ref arr idx dbg))) - | Pfloatarray -> - box_float dbg ( - bind "index" (transl env arg2) (fun idx -> - bind "arr" (transl env arg1) (fun arr -> - Csequence(make_checkbound dbg - [float_array_length(get_header_without_profinfo arr dbg) dbg; - idx], - unboxed_float_array_ref arr idx dbg)))) - end + arrayref_safe kind (transl env arg1) (transl env arg2) dbg (* Boxed integers *) | Paddbint bi -> @@ -2821,7 +986,7 @@ and transl_prim_2 env p arg1 arg2 dbg = [transl_unbox_int dbg env bi arg1; untag_int(transl env arg2) dbg], dbg)) | Pbintcomp(bi, cmp) -> - tag_int (Cop(Ccmpi(transl_int_comparison cmp), + tag_int (Cop(Ccmpi cmp, [transl_unbox_int dbg env bi arg1; transl_unbox_int dbg env bi arg2], dbg)) dbg | Pnot | Pnegint | Pintoffloat | Pfloatofint | Pnegfloat @@ -2841,130 +1006,39 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = match p with (* Heap operations *) | Psetfield_computed(ptr, init) -> - begin match assignment_kind ptr init with - | Caml_modify -> - return_unit dbg ( - addr_array_set (transl env arg1) (transl env arg2) (transl env arg3) - dbg) - | Caml_initialize -> - return_unit dbg ( - addr_array_initialize (transl env arg1) (transl env arg2) - (transl env arg3) dbg) - | Simple -> - return_unit dbg ( - int_array_set (transl env arg1) (transl env arg2) (transl env arg3) - dbg) - end + setfield_computed ptr init + (transl env arg1) (transl env arg2) (transl env arg3) dbg (* String operations *) | Pbytessetu -> - return_unit dbg (Cop(Cstore (Byte_unsigned, Assignment), - [add_int (transl env arg1) - (untag_int(transl env arg2) dbg) - dbg; - untag_int(transl env arg3) dbg], dbg)) + bytesset_unsafe + (transl env arg1) (transl env arg2) (transl env arg3) dbg | Pbytessets -> - return_unit dbg - (bind "str" (transl env arg1) (fun str -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - Csequence( - make_checkbound dbg [string_length str dbg; idx], - Cop(Cstore (Byte_unsigned, Assignment), - [add_int str idx dbg; untag_int(transl env arg3) dbg], - dbg))))) + bytesset_safe + (transl env arg1) (transl env arg2) (transl env arg3) dbg (* Array operations *) | Parraysetu kind -> - return_unit dbg (begin match kind with - Pgenarray -> - bind "newval" (transl env arg3) (fun newval -> - bind "index" (transl env arg2) (fun index -> - bind "arr" (transl env arg1) (fun arr -> - Cifthenelse(is_addr_array_ptr arr dbg, - dbg, - addr_array_set arr index newval dbg, - dbg, - float_array_set arr index (unbox_float dbg newval) - dbg, - dbg)))) - | Paddrarray -> - addr_array_set (transl env arg1) (transl env arg2) (transl env arg3) - dbg - | Pintarray -> - int_array_set (transl env arg1) (transl env arg2) (transl env arg3) - dbg - | Pfloatarray -> - float_array_set (transl env arg1) (transl env arg2) - (transl_unbox_float dbg env arg3) - dbg - end) + let newval = + match kind with + | Pfloatarray -> transl_unbox_float dbg env arg3 + | _ -> transl env arg3 + in + arrayset_unsafe kind (transl env arg1) (transl env arg2) newval dbg | Parraysets kind -> - return_unit dbg (begin match kind with - | Pgenarray -> - bind "newval" (transl env arg3) (fun newval -> - bind "index" (transl env arg2) (fun idx -> - bind "arr" (transl env arg1) (fun arr -> - bind "header" (get_header_without_profinfo arr dbg) (fun hdr -> - if wordsize_shift = numfloat_shift then - Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], - Cifthenelse(is_addr_array_hdr hdr dbg, - dbg, - addr_array_set arr idx newval dbg, - dbg, - float_array_set arr idx - (unbox_float dbg newval) - dbg, - dbg)) - else - Cifthenelse(is_addr_array_hdr hdr dbg, - dbg, - Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx], - addr_array_set arr idx newval dbg), - dbg, - Csequence(make_checkbound dbg [float_array_length hdr dbg; idx], - float_array_set arr idx - (unbox_float dbg newval) dbg), - dbg))))) - | Paddrarray -> - bind "newval" (transl env arg3) (fun newval -> - bind "index" (transl env arg2) (fun idx -> - bind "arr" (transl env arg1) (fun arr -> - Csequence(make_checkbound dbg [ - addr_array_length(get_header_without_profinfo arr dbg) dbg; idx], - addr_array_set arr idx newval dbg)))) - | Pintarray -> - bind "newval" (transl env arg3) (fun newval -> - bind "index" (transl env arg2) (fun idx -> - bind "arr" (transl env arg1) (fun arr -> - Csequence(make_checkbound dbg [ - addr_array_length(get_header_without_profinfo arr dbg) dbg; idx], - int_array_set arr idx newval dbg)))) - | Pfloatarray -> - bind_load "newval" (transl_unbox_float dbg env arg3) (fun newval -> - bind "index" (transl env arg2) (fun idx -> - bind "arr" (transl env arg1) (fun arr -> - Csequence(make_checkbound dbg [ - float_array_length (get_header_without_profinfo arr dbg) dbg;idx], - float_array_set arr idx newval dbg)))) - end) + let newval = + match kind with + | Pfloatarray -> transl_unbox_float dbg env arg3 + | _ -> transl env arg3 + in + arrayset_safe kind (transl env arg1) (transl env arg2) newval dbg | Pbytes_set(size, unsafe) -> - return_unit dbg - (bind "str" (transl env arg1) (fun str -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "newval" (transl_unbox_sized size dbg env arg3) (fun newval -> - check_bound unsafe size dbg (string_length str dbg) - idx (unaligned_set size str idx newval dbg))))) + bytes_set size unsafe (transl env arg1) (transl env arg2) + (transl_unbox_sized size dbg env arg3) dbg | Pbigstring_set(size, unsafe) -> - return_unit dbg - (bind "ba" (transl env arg1) (fun ba -> - bind "index" (untag_int (transl env arg2) dbg) (fun idx -> - bind "newval" (transl_unbox_sized size dbg env arg3) (fun newval -> - bind "ba_data" - (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) - (fun ba_data -> - check_bound unsafe size dbg (bigstring_length ba dbg) - idx (unaligned_set size ba_data idx newval dbg)))))) + bigstring_set size unsafe (transl env arg1) (transl env arg2) + (transl_unbox_sized size dbg env arg3) dbg | Pfield_computed | Psequand | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint @@ -3180,38 +1254,7 @@ and transl_switch loc env arg index cases = match Array.length cases with | 1 -> transl env cases.(0) | _ -> let cases = Array.map (transl env) cases in - let store = StoreExpForSwitch.mk_store () in - let index = - Array.map - (fun j -> store.Switch.act_store j cases.(j)) - index in - let n_index = Array.length index in - let inters = ref [] - and this_high = ref (n_index-1) - and this_low = ref (n_index-1) - and this_act = ref index.(n_index-1) in - for i = n_index-2 downto 0 do - let act = index.(i) in - if act = !this_act then - decr this_low - else begin - inters := (!this_low, !this_high, !this_act) :: !inters ; - this_high := i ; - this_low := i ; - this_act := act - end - done ; - inters := (0, !this_high, !this_act) :: !inters ; - match !inters with - | [_] -> cases.(0) - | inters -> - bind "switcher" arg - (fun a -> - SwitcherBlocks.zyva - loc - (0,n_index-1) - a - (Array.of_list inters) store) + transl_switch_clambda loc arg index cases and transl_letrec env bindings cont = let dbg = Debuginfo.none in @@ -3290,55 +1333,6 @@ let rec transl_all_functions already_translated cont = ((f.dbg, transl_function f) :: cont) end -(* Emit constant closures *) - -let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = - let closure_symbol f = - if Config.flambda then - cdefine_symbol (f.label ^ "_closure", global_symb) - else - [] - in - match fundecls with - [] -> - (* This should probably not happen: dead code has normally been - eliminated and a closure cannot be accessed without going through - a [Project_closure], which depends on the function. *) - assert (clos_vars = []); - cdefine_symbol symb @ - List.fold_right emit_constant clos_vars cont - | f1 :: remainder -> - let rec emit_others pos = function - [] -> - List.fold_right emit_constant clos_vars cont - | f2 :: rem -> - if f2.arity = 1 || f2.arity = 0 then - Cint(infix_header pos) :: - (closure_symbol f2) @ - Csymbol_address f2.label :: - cint_const f2.arity :: - emit_others (pos + 3) rem - else - Cint(infix_header pos) :: - (closure_symbol f2) @ - Csymbol_address(curry_function f2.arity) :: - cint_const f2.arity :: - Csymbol_address f2.label :: - emit_others (pos + 4) rem in - Cint(black_closure_header (fundecls_size fundecls - + List.length clos_vars)) :: - cdefine_symbol symb @ - (closure_symbol f1) @ - if f1.arity = 1 || f1.arity = 0 then - Csymbol_address f1.label :: - cint_const f1.arity :: - emit_others 3 remainder - else - Csymbol_address(curry_function f1.arity) :: - cint_const f1.arity :: - Csymbol_address f1.label :: - emit_others 4 remainder - (* Emit constant blocks *) let emit_constant_table symb elems = @@ -3369,7 +1363,8 @@ let emit_cmm_data_items_for_constants cont = match cst with | Const_closure (global, fundecls, clos_vars) -> let cmm = - emit_constant_closure (symbol, global) fundecls clos_vars [] + emit_constant_closure (symbol, global) fundecls + (List.fold_right emit_constant clos_vars []) [] in c := (Cdata cmm) :: !c | Const_table (global, elems) -> @@ -3398,53 +1393,6 @@ let transl_all_functions cont = in translated_functions @ cont -(* Build the NULL terminated array of gc roots *) - -let emit_gc_roots_table ~symbols cont = - let table_symbol = Compilenv.make_symbol (Some "gc_roots") in - Cdata(Cglobal_symbol table_symbol :: - Cdefine_symbol table_symbol :: - List.map (fun s -> Csymbol_address s) symbols @ - [Cint 0n]) - :: cont - -(* Build preallocated blocks (used for Flambda [Initialize_symbol] - constructs, and Clambda global module) *) - -let preallocate_block cont { Clambda.symbol; exported; tag; fields } = - let space = - (* These words will be registered as roots and as such must contain - valid values, in case we are in no-naked-pointers mode. Likewise - the block header must be black, below (see [caml_darken]), since - the overall record may be referenced. *) - List.map (fun field -> - match field with - | None -> - Cint (Nativeint.of_int 1 (* Val_unit *)) - | Some (Uconst_field_int n) -> - cint_const n - | Some (Uconst_field_ref label) -> - Csymbol_address label) - fields - in - let data = - Cint(black_block_header tag (List.length fields)) :: - if exported then - Cglobal_symbol symbol :: - Cdefine_symbol symbol :: space - else - Cdefine_symbol symbol :: space - in - Cdata data :: cont - -let emit_preallocated_blocks preallocated_blocks cont = - let symbols = - List.map (fun ({ Clambda.symbol }:Clambda.preallocated_block) -> symbol) - preallocated_blocks - in - let c1 = emit_gc_roots_table ~symbols cont in - List.fold_left preallocate_block c1 preallocated_blocks - (* Translate a compilation unit *) let compunit (ulam, preallocated_blocks, constants) = @@ -3475,499 +1423,3 @@ let compunit (ulam, preallocated_blocks, constants) = Cmmgen_state.set_structured_constants []; let c4 = emit_preallocated_blocks preallocated_blocks c3 in emit_cmm_data_items_for_constants c4 - -(* -CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) -{ - int li = 3, hi = Field(meths,0), mi; - while (li < hi) { // no need to check the 1st time - mi = ((li+hi) >> 1) | 1; - if (tag < Field(meths,mi)) hi = mi-2; - else li = mi; - } - *cache = (li-3)*sizeof(value)+1; - return Field (meths, li-1); -} -*) - -let cache_public_method meths tag cache dbg = - let raise_num = next_raise_count () in - let cconst_int i = Cconst_int (i, dbg) in - let li = V.create_local "*li*" and hi = V.create_local "*hi*" - and mi = V.create_local "*mi*" and tagged = V.create_local "*tagged*" in - Clet ( - VP.create li, cconst_int 3, - Clet ( - VP.create hi, Cop(Cload (Word_int, Mutable), [meths], dbg), - Csequence( - ccatch - (raise_num, [], - create_loop - (Clet( - VP.create mi, - Cop(Cor, - [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); cconst_int 1], - dbg); - cconst_int 1], - dbg), - Csequence( - Cifthenelse - (Cop (Ccmpi Clt, - [tag; - Cop(Cload (Word_int, Mutable), - [Cop(Cadda, - [meths; lsl_const (Cvar mi) log2_size_addr dbg], - dbg)], - dbg)], dbg), - dbg, Cassign(hi, Cop(Csubi, [Cvar mi; cconst_int 2], dbg)), - dbg, Cassign(li, Cvar mi), - dbg), - Cifthenelse - (Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg), - dbg, Cexit (raise_num, []), - dbg, Ctuple [], - dbg)))) - dbg, - Ctuple [], - dbg), - Clet ( - VP.create tagged, - Cop(Cadda, [lsl_const (Cvar li) log2_size_addr dbg; - cconst_int(1 - 3 * size_addr)], dbg), - Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg), - Cvar tagged))))) - -(* CR mshinwell: These will be filled in by later pull requests. *) -let placeholder_dbg () = Debuginfo.none -let placeholder_fun_dbg ~human_name:_ = Debuginfo.none - -(* Generate an application function: - (defun caml_applyN (a1 ... aN clos) - (if (= clos.arity N) - (app clos.direct a1 ... aN clos) - (let (clos1 (app clos.code a1 clos) - clos2 (app clos1.code a2 clos) - ... - closN-1 (app closN-2.code aN-1 closN-2)) - (app closN-1.code aN closN-1)))) -*) - -let apply_function_body arity = - let dbg = placeholder_dbg in - let arg = Array.make arity (V.create_local "arg") in - for i = 1 to arity - 1 do arg.(i) <- V.create_local "arg" done; - let clos = V.create_local "clos" in - let env = empty_env in - let rec app_fun clos n = - if n = arity-1 then - Cop(Capply typ_val, - [get_field env (Cvar clos) 0 (dbg ()); Cvar arg.(n); Cvar clos], - dbg ()) - else begin - let newclos = V.create_local "clos" in - Clet(VP.create newclos, - Cop(Capply typ_val, - [get_field env (Cvar clos) 0 (dbg ()); Cvar arg.(n); Cvar clos], - dbg ()), - app_fun newclos (n+1)) - end in - let args = Array.to_list arg in - let all_args = args @ [clos] in - (args, clos, - if arity = 1 then app_fun clos 0 else - Cifthenelse( - Cop(Ccmpi Ceq, - [get_field env (Cvar clos) 1 (dbg ()); int_const (dbg ()) arity], dbg ()), - dbg (), - Cop(Capply typ_val, - get_field env (Cvar clos) 2 (dbg ()) - :: List.map (fun s -> Cvar s) all_args, - dbg ()), - dbg (), - app_fun clos 0, - dbg ())) - -let send_function arity = - let dbg = placeholder_dbg in - let cconst_int i = Cconst_int (i, dbg ()) in - let (args, clos', body) = apply_function_body (1+arity) in - let cache = V.create_local "cache" - and obj = List.hd args - and tag = V.create_local "tag" in - let env = empty_env in - let clos = - let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in - let meths = V.create_local "meths" and cached = V.create_local "cached" in - let real = V.create_local "real" in - let mask = get_field env (Cvar meths) 1 (dbg ()) in - let cached_pos = Cvar cached in - let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg ()); - cconst_int(3*size_addr-1)], dbg ()) in - let tag' = Cop(Cload (Word_int, Mutable), [tag_pos], dbg ()) in - Clet ( - VP.create meths, Cop(Cload (Word_val, Mutable), [obj], dbg ()), - Clet ( - VP.create cached, - Cop(Cand, [Cop(Cload (Word_int, Mutable), [cache], dbg ()); mask], - dbg ()), - Clet ( - VP.create real, - Cifthenelse(Cop(Ccmpa Cne, [tag'; tag], dbg ()), - dbg (), - cache_public_method (Cvar meths) tag cache (dbg ()), - dbg (), - cached_pos, - dbg ()), - Cop(Cload (Word_val, Mutable), - [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths], dbg ()); - cconst_int(2*size_addr-1)], dbg ())], dbg ())))) - - in - let body = Clet(VP.create clos', clos, body) in - let cache = cache in - let fun_name = "caml_send" ^ Int.to_string arity in - let fun_args = - [obj, typ_val; tag, typ_int; cache, typ_val] - @ List.map (fun id -> (id, typ_val)) (List.tl args) in - let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in - Cfunction - {fun_name; - fun_args = List.map (fun (arg, ty) -> VP.create arg, ty) fun_args; - fun_body = body; - fun_codegen_options = []; - fun_dbg; - } - -let apply_function arity = - let (args, clos, body) = apply_function_body arity in - let all_args = args @ [clos] in - let fun_name = "caml_apply" ^ Int.to_string arity in - let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in - Cfunction - {fun_name; - fun_args = List.map (fun arg -> (VP.create arg, typ_val)) all_args; - fun_body = body; - fun_codegen_options = []; - fun_dbg; - } - -(* Generate tuplifying functions: - (defun caml_tuplifyN (arg clos) - (app clos.direct #0(arg) ... #N-1(arg) clos)) *) - -let tuplify_function arity = - let dbg = placeholder_dbg in - let arg = V.create_local "arg" in - let clos = V.create_local "clos" in - let env = empty_env in - let rec access_components i = - if i >= arity - then [] - else get_field env (Cvar arg) i (dbg ()) :: access_components(i+1) in - let fun_name = "caml_tuplify" ^ Int.to_string arity in - let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in - Cfunction - {fun_name; - fun_args = [VP.create arg, typ_val; VP.create clos, typ_val]; - fun_body = - Cop(Capply typ_val, - get_field env (Cvar clos) 2 (dbg ()) - :: access_components 0 @ [Cvar clos], - dbg ()); - fun_codegen_options = []; - fun_dbg; - } - -(* Generate currying functions: - (defun caml_curryN (arg clos) - (alloc HDR caml_curryN_1 caml_curry_N_1_app arg clos)) - (defun caml_curryN_1 (arg clos) - (alloc HDR caml_curryN_2 caml_curry_N_2_app arg clos)) - ... - (defun caml_curryN_N-1 (arg clos) - (let (closN-2 clos.vars[1] - closN-3 closN-2.vars[1] - ... - clos1 clos2.vars[1] - clos clos1.vars[1]) - (app clos.direct - clos1.vars[0] ... closN-2.vars[0] clos.vars[0] arg clos))) - - Special "shortcut" functions are also generated to handle the - case where a partially applied function is applied to all remaining - arguments in one go. For instance: - (defun caml_curry_N_1_app (arg2 ... argN clos) - (let clos' clos.vars[1] - (app clos'.direct clos.vars[0] arg2 ... argN clos'))) - - Those shortcuts may lead to a quadratic number of application - primitives being generated in the worst case, which resulted in - linking time blowup in practice (PR#5933), so we only generate and - use them when below a fixed arity 'max_arity_optimized'. -*) - -let max_arity_optimized = 15 -let final_curry_function arity = - let dbg = placeholder_dbg in - let last_arg = V.create_local "arg" in - let last_clos = V.create_local "clos" in - let env = empty_env in - let rec curry_fun args clos n = - if n = 0 then - Cop(Capply typ_val, - get_field env (Cvar clos) 2 (dbg ()) :: - args @ [Cvar last_arg; Cvar clos], - dbg ()) - else - if n = arity - 1 || arity > max_arity_optimized then - begin - let newclos = V.create_local "clos" in - Clet(VP.create newclos, - get_field env (Cvar clos) 3 (dbg ()), - curry_fun (get_field env (Cvar clos) 2 (dbg ()) :: args) - newclos (n-1)) - end else - begin - let newclos = V.create_local "clos" in - Clet(VP.create newclos, - get_field env (Cvar clos) 4 (dbg ()), - curry_fun (get_field env (Cvar clos) 3 (dbg ()) :: args) - newclos (n-1)) - end in - let fun_name = - "caml_curry" ^ Int.to_string arity ^ "_" ^ Int.to_string (arity-1) - in - let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in - Cfunction - {fun_name; - fun_args = [VP.create last_arg, typ_val; VP.create last_clos, typ_val]; - fun_body = curry_fun [] last_clos (arity-1); - fun_codegen_options = []; - fun_dbg; - } - -let rec intermediate_curry_functions arity num = - let dbg = placeholder_dbg in - let env = empty_env in - if num = arity - 1 then - [final_curry_function arity] - else begin - let name1 = "caml_curry" ^ Int.to_string arity in - let name2 = if num = 0 then name1 else name1 ^ "_" ^ Int.to_string num in - let arg = V.create_local "arg" and clos = V.create_local "clos" in - let fun_dbg = placeholder_fun_dbg ~human_name:name2 in - Cfunction - {fun_name = name2; - fun_args = [VP.create arg, typ_val; VP.create clos, typ_val]; - fun_body = - if arity - num > 2 && arity <= max_arity_optimized then - Cop(Calloc, - [alloc_closure_header 5 Debuginfo.none; - Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ()); - int_const (dbg ()) (arity - num - 1); - Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1) ^ "_app", - dbg ()); - Cvar arg; Cvar clos], - dbg ()) - else - Cop(Calloc, - [alloc_closure_header 4 (dbg ()); - Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ()); - int_const (dbg ()) 1; Cvar arg; Cvar clos], - dbg ()); - fun_codegen_options = []; - fun_dbg; - } - :: - (if arity <= max_arity_optimized && arity - num > 2 then - let rec iter i = - if i <= arity then - let arg = V.create_local (Printf.sprintf "arg%d" i) in - (arg, typ_val) :: iter (i+1) - else [] - in - let direct_args = iter (num+2) in - let rec iter i args clos = - if i = 0 then - Cop(Capply typ_val, - (get_field env (Cvar clos) 2 (dbg ())) :: args @ [Cvar clos], - dbg ()) - else - let newclos = V.create_local "clos" in - Clet(VP.create newclos, - get_field env (Cvar clos) 4 (dbg ()), - iter (i-1) (get_field env (Cvar clos) 3 (dbg ()) :: args) - newclos) - in - let fun_args = - List.map (fun (arg, ty) -> VP.create arg, ty) - (direct_args @ [clos, typ_val]) - in - let fun_name = name1 ^ "_" ^ Int.to_string (num+1) ^ "_app" in - let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in - let cf = - Cfunction - {fun_name; - fun_args; - fun_body = iter (num+1) - (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; - fun_codegen_options = []; - fun_dbg; - } - in - cf :: intermediate_curry_functions arity (num+1) - else - intermediate_curry_functions arity (num+1)) - end - -let curry_function arity = - assert(arity <> 0); - (* Functions with arity = 0 does not have a curry_function *) - if arity > 0 - then intermediate_curry_functions arity 0 - else [tuplify_function (-arity)] - -module Int = Numbers.Int - -let default_apply = Int.Set.add 2 (Int.Set.add 3 Int.Set.empty) - (* These apply funs are always present in the main program because - the run-time system needs them (cf. runtime/.S) . *) - -let generic_functions shared units = - let (apply,send,curry) = - List.fold_left - (fun (apply,send,curry) ui -> - List.fold_right Int.Set.add ui.ui_apply_fun apply, - List.fold_right Int.Set.add ui.ui_send_fun send, - List.fold_right Int.Set.add ui.ui_curry_fun curry) - (Int.Set.empty,Int.Set.empty,Int.Set.empty) - units in - let apply = if shared then apply else Int.Set.union apply default_apply in - let accu = Int.Set.fold (fun n accu -> apply_function n :: accu) apply [] in - let accu = Int.Set.fold (fun n accu -> send_function n :: accu) send accu in - Int.Set.fold (fun n accu -> curry_function n @ accu) curry accu - -(* Generate the entry point *) - -let entry_point namelist = - let dbg = placeholder_dbg in - let cconst_int i = Cconst_int (i, dbg ()) in - let cconst_symbol sym = Cconst_symbol (sym, dbg ()) in - let incr_global_inited () = - Cop(Cstore (Word_int, Assignment), - [cconst_symbol "caml_globals_inited"; - Cop(Caddi, [Cop(Cload (Word_int, Mutable), - [cconst_symbol "caml_globals_inited"], dbg ()); - cconst_int 1], dbg ())], dbg ()) in - let body = - List.fold_right - (fun name next -> - let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in - Csequence(Cop(Capply typ_void, - [cconst_symbol entry_sym], dbg ()), - Csequence(incr_global_inited (), next))) - namelist (cconst_int 1) in - let fun_name = "caml_program" in - let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in - Cfunction {fun_name; - fun_args = []; - fun_body = body; - fun_codegen_options = [Reduce_code_size]; - fun_dbg; - } - -(* Generate the table of globals *) - -let cint_zero = Cint 0n - -let global_table namelist = - let mksym name = - Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "gc_roots")) - in - Cdata(Cglobal_symbol "caml_globals" :: - Cdefine_symbol "caml_globals" :: - List.map mksym namelist @ - [cint_zero]) - -let reference_symbols namelist = - let mksym name = Csymbol_address name in - Cdata(List.map mksym namelist) - -let global_data name v = - Cdata(emit_structured_constant (name, Global) - (Uconst_string (Marshal.to_string v [])) []) - -let globals_map v = global_data "caml_globals_map" v - -(* Generate the master table of frame descriptors *) - -let frame_table namelist = - let mksym name = - Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "frametable")) - in - Cdata(Cglobal_symbol "caml_frametable" :: - Cdefine_symbol "caml_frametable" :: - List.map mksym namelist - @ [cint_zero]) - -(* Generate the master table of Spacetime shapes *) - -let spacetime_shapes namelist = - let mksym name = - Csymbol_address ( - Compilenv.make_symbol ~unitname:name (Some "spacetime_shapes")) - in - Cdata(Cglobal_symbol "caml_spacetime_shapes" :: - Cdefine_symbol "caml_spacetime_shapes" :: - List.map mksym namelist - @ [cint_zero]) - -(* Generate the table of module data and code segments *) - -let segment_table namelist symbol begname endname = - let addsyms name lst = - Csymbol_address (Compilenv.make_symbol ~unitname:name (Some begname)) :: - Csymbol_address (Compilenv.make_symbol ~unitname:name (Some endname)) :: - lst - in - Cdata(Cglobal_symbol symbol :: - Cdefine_symbol symbol :: - List.fold_right addsyms namelist [cint_zero]) - -let data_segment_table namelist = - segment_table namelist "caml_data_segments" "data_begin" "data_end" - -let code_segment_table namelist = - segment_table namelist "caml_code_segments" "code_begin" "code_end" - -(* Initialize a predefined exception *) - -let predef_exception i name = - let name_sym = Compilenv.new_const_symbol () in - let data_items = - emit_block name_sym Local (string_header (String.length name)) - (emit_string_constant name []) - in - let exn_sym = "caml_exn_" ^ name in - let tag = Obj.object_tag in - let size = 2 in - let fields = - (Csymbol_address name_sym) - :: (cint_const (-i - 1)) - :: data_items - in - let data_items = emit_block exn_sym Global (block_header tag size) fields in - Cdata data_items - -(* Header for a plugin *) - -let plugin_header units = - let mk (ui,crc) = - { dynu_name = ui.ui_name; - dynu_crc = crc; - dynu_imports_cmi = ui.ui_imports_cmi; - dynu_imports_cmx = ui.ui_imports_cmx; - dynu_defines = ui.ui_defines - } in - global_data "caml_plugin_header" - { dynu_magic = Config.cmxs_magic_number; dynu_units = List.map mk units } diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 8fbcb8524e..a954a28424 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -20,20 +20,3 @@ val compunit * Clambda.preallocated_block list * Clambda.preallocated_constant list -> Cmm.phrase list - -val apply_function: int -> Cmm.phrase -val send_function: int -> Cmm.phrase -val curry_function: int -> Cmm.phrase list -val generic_functions: bool -> Cmx_format.unit_infos list -> Cmm.phrase list -val entry_point: string list -> Cmm.phrase -val global_table: string list -> Cmm.phrase -val reference_symbols: string list -> Cmm.phrase -val globals_map: - (string * Digest.t option * Digest.t option * string list) list -> Cmm.phrase -val frame_table: string list -> Cmm.phrase -val spacetime_shapes: string list -> Cmm.phrase -val data_segment_table: string list -> Cmm.phrase -val code_segment_table: string list -> Cmm.phrase -val predef_exception: int -> string -> Cmm.phrase -val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase -val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint diff --git a/asmcomp/cmmgen_state.ml b/asmcomp/cmmgen_state.ml index c4023e0cc9..595aba4d9c 100644 --- a/asmcomp/cmmgen_state.ml +++ b/asmcomp/cmmgen_state.ml @@ -78,3 +78,8 @@ let set_structured_constants l = let get_structured_constant s = Hashtbl.find_opt state.structured_constants s + +let structured_constant_of_sym s = + match Compilenv.structured_constant_of_symbol s with + | None -> get_structured_constant s + | Some _ as r -> r diff --git a/asmcomp/cmmgen_state.mli b/asmcomp/cmmgen_state.mli index c5c3d550cb..306f55d5cc 100644 --- a/asmcomp/cmmgen_state.mli +++ b/asmcomp/cmmgen_state.mli @@ -41,4 +41,5 @@ val no_more_functions : unit -> bool val set_structured_constants : Clambda.preallocated_constant list -> unit -val get_structured_constant : string -> Clambda.ustructured_constant option +(* Also looks up using Compilenv.structured_constant_of_symbol *) +val structured_constant_of_sym : string -> Clambda.ustructured_constant option From 285b9806deff44dba0e883ae5914459e42206b76 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Fri, 4 Oct 2019 18:54:07 +0200 Subject: [PATCH 5/9] remove disambiguation for constructor map (#9017) remove disambiguation for constructor map --- typing/typecore.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/typing/typecore.ml b/typing/typecore.ml index 1e71d2f492..2afd7d51d6 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1165,14 +1165,13 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode Some (p0, p, true) with Not_found -> None in - let candidates = + let constr = match lid.txt, constrs with - Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> - Ok [Hashtbl.find constrs s, (fun () -> ())] + Longident.Lident s, Some constrs -> + assert (Hashtbl.mem constrs s); Hashtbl.find constrs s | _ -> - Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env - in - let constr = + let candidates = + Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in wrap_disambiguate "This variant pattern is expected to have" (mk_expected expected_ty) (Constructor.disambiguate Env.Pattern lid !env opath) candidates From 16a13e668b86a51b472a0b1cce2d8ea654098d3a Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Sat, 5 Oct 2019 13:17:57 +0200 Subject: [PATCH 6/9] fix issue #8792 and replace log_type by set_type_desc in Btype (#9018) --- Changes | 4 ++++ typing/btype.ml | 5 +++++ typing/btype.mli | 4 ++-- typing/ctype.ml | 23 ++++++++++------------- typing/typecore.ml | 2 +- typing/typetexp.ml | 4 ++-- 6 files changed, 24 insertions(+), 18 deletions(-) diff --git a/Changes b/Changes index c28998e89c..f0daf4275a 100644 --- a/Changes +++ b/Changes @@ -296,6 +296,10 @@ Working version (Gabriel Scherer and Florian Angeletti, review by Florian Angeletti and Gabriel Radanne) +- #8792, #9018: Possible (latent) bug in Ctype.normalize_type + removed incrimined Btype.log_type, replaced by Btype.set_type + (Jacques Garrigue, report by Alain Frisch, review by Thomas Refis) + - #8855, #8858: Links for tools not created when installing with --disable-installing-byecode-programs (e.g. ocamldep.opt installed, but ocamldep link not created) diff --git a/typing/btype.ml b/typing/btype.ml index c85751c60e..a4256dfbc1 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -737,6 +737,11 @@ let link_type ty ty' = | _ -> () (* ; assert (check_memorized_abbrevs ()) *) (* ; check_expans [] ty' *) +let set_type_desc ty td = + if td != ty.desc then begin + log_type ty; + ty.desc <- td + end let set_level ty level = if level <> ty.level then begin if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); diff --git a/typing/btype.mli b/typing/btype.mli index 325f6772c5..d74a1b51c3 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -227,6 +227,8 @@ val undo_compress: snapshot -> unit val link_type: type_expr -> type_expr -> unit (* Set the desc field of [t1] to [Tlink t2], logging the old value if there is an active snapshot *) +val set_type_desc: type_expr -> type_desc -> unit + (* Set directly the desc field, without sharing *) val set_level: type_expr -> int -> unit val set_scope: type_expr -> int -> unit val set_name: @@ -238,8 +240,6 @@ val set_kind: field_kind option ref -> field_kind -> unit val set_commu: commutable ref -> commutable -> unit val set_typeset: TypeSet.t ref -> TypeSet.t -> unit (* Set references, logging the old value *) -val log_type: type_expr -> unit - (* Log the old value of a type, before modifying it by hand *) (**** Forward declarations ****) val print_raw: (Format.formatter -> type_expr -> unit) ref diff --git a/typing/ctype.ml b/typing/ctype.ml index 02b97214e7..634a77a070 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -848,7 +848,7 @@ let rec update_level env level expand ty = | Tpackage (p, nl, tl) when level < Path.scope p -> let p' = normalize_package_path env p in if Path.same p p' then raise Trace.(Unify [escape (Module_type p)]); - log_type ty; ty.desc <- Tpackage (p', nl, tl); + set_type_desc ty (Tpackage (p', nl, tl)); update_level env level expand ty | Tobject(_, ({contents=Some(p, _tl)} as nm)) when level < Path.scope p -> @@ -858,8 +858,7 @@ let rec update_level env level expand ty = let row = row_repr row in begin match row.row_name with | Some (p, _tl) when level < Path.scope p -> - log_type ty; - ty.desc <- Tvariant {row with row_name = None} + set_type_desc ty (Tvariant {row with row_name = None}) | _ -> () end; set_level ty level; @@ -2751,7 +2750,7 @@ and unify_list env tl1 tl2 = and make_rowvar level use1 rest1 use2 rest2 = let set_name ty name = match ty.desc with - Tvar None -> log_type ty; ty.desc <- Tvar name + Tvar None -> set_type_desc ty (Tvar name) | _ -> () in let name = @@ -2791,8 +2790,8 @@ and unify_fields env ty1 ty2 = (* Optimization *) ) pairs with exn -> - log_type rest1; rest1.desc <- d1; - log_type rest2; rest2.desc <- d2; + set_type_desc rest1 d1; + set_type_desc rest2 d2; raise exn and unify_kind k1 k2 = @@ -2902,7 +2901,7 @@ and unify_row env row1 row2 = if is_Tvar rm then link_type rm (newty2 rm.level Tnil) end with exn -> - log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn + set_type_desc rm1 md1; set_type_desc rm2 md2; raise exn end and unify_row_field env fixed1 fixed2 more l f1 f2 = @@ -4444,8 +4443,7 @@ let rec normalize_type_rec env visited ty = match tm.desc with (* PR#7348 *) Tconstr (Path.Pdot(m,i), tl, _abbrev) -> let i' = String.sub i 0 (String.length i - 4) in - log_type ty; - ty.desc <- Tconstr(Path.Pdot(m,i'), tl, ref Mnil) + set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil)) | _ -> assert false else match ty.desc with | Tvariant row -> @@ -4469,8 +4467,7 @@ let rec normalize_type_rec env visited ty = let fields = List.sort (fun (p,_) (q,_) -> compare p q) (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in - log_type ty; - ty.desc <- Tvariant {row with row_fields = fields} + set_type_desc ty (Tvariant {row with row_fields = fields}) | Tobject (fi, nm) -> begin match !nm with | None -> () @@ -4483,7 +4480,7 @@ let rec normalize_type_rec env visited ty = | Tvar _ | Tunivar _ -> if v' != v then set_name nm (Some (n, v' :: l)) | Tnil -> - log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) + set_type_desc ty (Tconstr (n, l, ref Mnil)) | _ -> set_name nm None end | _ -> @@ -4493,7 +4490,7 @@ let rec normalize_type_rec env visited ty = if fi.level < lowest_level then () else let fields, row = flatten_fields fi in let fi' = build_fields fi.level fields row in - log_type ty; fi.desc <- fi'.desc + set_type_desc fi fi'.desc | _ -> () end; iter_type_expr (normalize_type_rec env visited) ty diff --git a/typing/typecore.ml b/typing/typecore.ml index 2afd7d51d6..f353b65d34 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1885,7 +1885,7 @@ let check_univars env expans kind exp ty_expected vars = generalize t; match t.desc with Tvar name when t.level = generic_level -> - log_type t; t.desc <- Tunivar name; true + set_type_desc t (Tunivar name); true | _ -> false) vars in if List.length vars = List.length vars' then () else diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 9784b73d74..9e53551a7f 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -361,8 +361,8 @@ and transl_type_aux env policy styp = let t = instance t in let px = Btype.proxy t in begin match px.desc with - | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias) - | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias) + | Tvar None -> Btype.set_type_desc px (Tvar (Some alias)) + | Tunivar None -> Btype.set_type_desc px (Tunivar (Some alias)) | _ -> () end; { ty with ctyp_type = t } From 345fd4c3f967ddc45bf6ce609ccdc52d9fda22b3 Mon Sep 17 00:00:00 2001 From: David Allsopp Date: Sun, 29 Sep 2019 12:11:57 +0100 Subject: [PATCH 7/9] Allow Git config options to be passed to configure The Git configuration value ocaml.configure is now passed to the configure script's arguments before $@ if (and only if) OCaml is being configured from a Git clone. This allows, for example: - Developer-specific preferences (e.g. `--disable-ocamldoc` or `--disable-debug-runtime`) - Automatic use of autoconf cach files (-C option) It is implemented by inserting a test at the top of `configure`, which is bypassed if `.git` doesn't exist. --- Changes | 4 ++++ HACKING.adoc | 16 ++++++++++++++++ Makefile | 2 +- autogen | 10 +++++++++- configure | 15 +++++++++++++++ tools/git-dev-options.sh | 30 ++++++++++++++++++++++++++++++ 6 files changed, 75 insertions(+), 2 deletions(-) create mode 100755 tools/git-dev-options.sh diff --git a/Changes b/Changes index f0daf4275a..06a6fe28b5 100644 --- a/Changes +++ b/Changes @@ -265,6 +265,10 @@ Working version incompatible with C. (David Allsopp, review by Nicolás Ojeda Bär, report by Sebastian Rasmussen) +- #8995: allow developers to specify frequently-used configure options in + Git (ocaml.configure option) See HACKING.adoc for further details. + (David Allsopp, review by Gabriel Scherer) + ### Compiler user-interface and warnings: - #8702, #8777: improved error messages for fixed row polymorphic variants diff --git a/HACKING.adoc b/HACKING.adoc index 8eb4b53be5..48cb2b2e7d 100644 --- a/HACKING.adoc +++ b/HACKING.adoc @@ -233,6 +233,22 @@ Additionally, there are some developer specific targets in link:Makefile.dev[]. These targets are automatically available when working in a Git clone of the repository, but are not available from a tarball. +=== Automatic configure options + +If you have options to `configure` which you always (or at least frequently) +use, it's possible to store them in Git, and `configure` will automatically add +them. For example, you may wish to avoid building the debug runtime by default +while developing, in which case you can issue +`git config --global ocaml.configure '--disable-debug-runtime'`. The `configure` +script will alert you that it has picked up this option and added it _before_ +any options you specified for `configure`. + +Options are added before those passed on the command line, so it's possible to +override them, for example `./configure --enable-debug-runtime` will build the +debug runtime, since the enable flag appears after the disable flag. You can +also use the full power of Git's `config` command and have options specific to +particular clone or worktree. + === Bootstrapping The OCaml compiler is bootstrapped. This means that diff --git a/Makefile b/Makefile index c4c113a4c4..f10ca0b3d3 100644 --- a/Makefile +++ b/Makefile @@ -326,7 +326,7 @@ utils/config.ml: utils/config.mlp Makefile.config utils/Makefile .PHONY: reconfigure reconfigure: - ./configure $(CONFIGURE_ARGS) + ac_read_git_config=true ./configure $(CONFIGURE_ARGS) utils/domainstate.ml: utils/domainstate.ml.c runtime/caml/domain_state.tbl $(CPP) -I runtime/caml $< > $@ diff --git a/autogen b/autogen index 740a4ca15b..8c85c2cba8 100755 --- a/autogen +++ b/autogen @@ -17,6 +17,11 @@ rm -rf autom4te.cache autoconf --force --warnings=all,error + +# Allow pre-processing of configure arguments for Git check-outs +# The sed call removes dra27's copyright on the whole configure script... +sed -e '/^#[^!]/d' tools/git-dev-options.sh > configure.tmp + # Some distros have the 2013 --runstatedir patch to autoconf (see # http://git.savannah.gnu.org/cgit/autoconf.git/commit/?id=a197431414088a417b407b9b20583b2e8f7363bd # in the GNU autoconf repo), and some don't, so ensure its effects are @@ -27,6 +32,9 @@ autoconf --force --warnings=all,error sed -e '/^runstatedir/d' \ -e '/-runstatedir /{N;N;N;N;N;N;N;N;d;}' \ -e '/--runstatedir=DIR/d' \ - -e 's/ runstatedir//' configure > configure.tmp + -e 's/ runstatedir//' \ + -e '1d' \ + configure >> configure.tmp + mv -f configure.tmp configure chmod +x configure diff --git a/configure b/configure index 3e45e09ff3..f30b41d17a 100755 --- a/configure +++ b/configure @@ -1,4 +1,19 @@ #! /bin/sh + +if test -e '.git' ; then : + extra_args=$(git config ocaml.configure 2>/dev/null) + if test -n "$extra_args" ; then : + if test -z "$ac_read_git_config" ; then : + echo "Detected Git configuration option ocaml.configure set to \ +\"$extra_args\"" + # Too much effort to get the echo to show appropriate quoting - the + # invocation itself intentionally quotes $0 and passes $@ exactly as given + # but allows a single expansion of ocaml.configure + echo "Re-running $0 $extra_args $@" + ac_read_git_config=true exec "$0" $extra_args "$@" + fi + fi +fi # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for OCaml 4.10.0+dev0-2019-04-23. # diff --git a/tools/git-dev-options.sh b/tools/git-dev-options.sh new file mode 100755 index 0000000000..21e60f50f2 --- /dev/null +++ b/tools/git-dev-options.sh @@ -0,0 +1,30 @@ +#! /bin/sh +#************************************************************************** +#* * +#* OCaml * +#* * +#* David Allsopp, OCaml Labs, Cambridge. * +#* * +#* Copyright 2019 MetaStack Solutions Ltd. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +# This script should have the same shebang as configure +if test -e '.git' ; then : + extra_args=$(git config ocaml.configure 2>/dev/null) + if test -n "$extra_args" ; then : + if test -z "$ac_read_git_config" ; then : + echo "Detected Git configuration option ocaml.configure set to \ +\"$extra_args\"" + # Too much effort to get the echo to show appropriate quoting - the + # invocation itself intentionally quotes $0 and passes $@ exactly as given + # but allows a single expansion of ocaml.configure + echo "Re-running $0 $extra_args $@" + ac_read_git_config=true exec "$0" $extra_args "$@" + fi + fi +fi From 4f09104d882102dd45e3462e937dd32b4f3fdd26 Mon Sep 17 00:00:00 2001 From: David Allsopp Date: Sun, 29 Sep 2019 12:14:49 +0100 Subject: [PATCH 8/9] Allow by-host worktree-sharable configure caches The Git configuration value ocaml.configure-cache can be used to specify a directory to keep autoconf cache files in, relative to the worktree root (so `git config ocaml.configure-cache .` enables the feature, and `git config --global ocaml.configure-cache ..` enables it for all worktrees, assuming they're at the same level). autoconf's --cache-file option speeds up future runs of configure by caching the results of previous tests. The cache is invalidated if any environment variables differ (e.g. LDFLAGS) or if the build-host-target triplet differs. This is a nuisance on Windows, where configure is both very slow and it's also common to build with multiple different --host values. This PR allows a tree to be quickly reconfigured from one Windows port to another. --- .gitignore | 1 + Changes | 4 +++- HACKING.adoc | 17 ++++++++++++++ configure | 51 ++++++++++++++++++++++++++++++++++++---- tools/git-dev-options.sh | 51 ++++++++++++++++++++++++++++++++++++---- 5 files changed, 113 insertions(+), 11 deletions(-) diff --git a/.gitignore b/.gitignore index ff1bf28050..5da73a826e 100644 --- a/.gitignore +++ b/.gitignore @@ -45,6 +45,7 @@ _build /autom4te.cache /ocamlc /config.cache +/ocaml-*.cache /config.log /config.status /libtool diff --git a/Changes b/Changes index 06a6fe28b5..1371ce1683 100644 --- a/Changes +++ b/Changes @@ -266,7 +266,9 @@ Working version (David Allsopp, review by Nicolás Ojeda Bär, report by Sebastian Rasmussen) - #8995: allow developers to specify frequently-used configure options in - Git (ocaml.configure option) See HACKING.adoc for further details. + Git (ocaml.configure option) and a directory for host-specific, shareable + config.cache files (ocaml.configure-cache option). See HACKING.adoc for + further details. (David Allsopp, review by Gabriel Scherer) ### Compiler user-interface and warnings: diff --git a/HACKING.adoc b/HACKING.adoc index 48cb2b2e7d..ea25c98894 100644 --- a/HACKING.adoc +++ b/HACKING.adoc @@ -249,6 +249,23 @@ debug runtime, since the enable flag appears after the disable flag. You can also use the full power of Git's `config` command and have options specific to particular clone or worktree. +=== Speeding up configure + +`configure` includes the standard `-C` option which caches various test results +in the file `config.cache` and can use those results to avoid running tests in +subsequent invocations. This mechanism works fine, except that it is easy to +clean the cache by mistake (e.g. with `git clean -dfX`). The cache is also +host-specific which means the file has to be deleted if you run `configure` with +a new `--host` value (this is quite common on Windows, where `configure` is +also quite slow to run). + +You can elect to have host-specific cache files by issuing +`git config --global ocaml.configure-cache .`. The `configure` script will now +automatically create `ocaml-host.cache` (e.g. `ocaml-x86_64-pc-windows.cache`, +or `ocaml-default.cache`). If you work with multiple worktrees, you can share +these cache files by issuing `git config --global ocaml.configure-cache ..`. The +directory is interpreted _relative_ to the `configure` script. + === Bootstrapping The OCaml compiler is bootstrapped. This means that diff --git a/configure b/configure index f30b41d17a..34a7f7c28e 100755 --- a/configure +++ b/configure @@ -1,16 +1,57 @@ #! /bin/sh if test -e '.git' ; then : - extra_args=$(git config ocaml.configure 2>/dev/null) - if test -n "$extra_args" ; then : - if test -z "$ac_read_git_config" ; then : + if test -z "$ac_read_git_config" ; then : + extra_args=$(git config ocaml.configure 2>/dev/null) + extended_cache=$(git config ocaml.configure-cache 2>/dev/null) + cache_file= + + # If ocaml.configure-cache is set, parse the command-line for the --host + # option, in order to determine the name of the cache file. + if test -n "$extended_cache" ; then : + echo "Detected Git configuration option ocaml.configure-cache set to \ +\"$extended_cache\"" + dashdash= + prev= + host=default + # The logic here is pretty borrowed from autoconf's + for option in $extra_args "$@" + do + if test -n "$prev" ; then : + host=$option + continue + fi + + case $dashdash$option in + --) + dashdash=yes ;; + -host | --host | --hos | --ho) + prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + case $option in + *=?*) host=$(expr "X$option" : '[^=]*=\(.*\)') ;; + *=) host= ;; + esac ;; + esac + done + cache_file="`dirname "$0"`/$extended_cache/ocaml-$host.cache" + fi + + # If either option has a value, re-invoke configure + if test -n "$extra_args$cache_file" ; then : echo "Detected Git configuration option ocaml.configure set to \ \"$extra_args\"" # Too much effort to get the echo to show appropriate quoting - the # invocation itself intentionally quotes $0 and passes $@ exactly as given # but allows a single expansion of ocaml.configure - echo "Re-running $0 $extra_args $@" - ac_read_git_config=true exec "$0" $extra_args "$@" + if test -n "$cache_file" ; then : + echo "Re-running $0 $extra_args --cache-file \"$cache_file\" $@" + ac_read_git_config=true exec "$0" $extra_args \ + --cache-file "$cache_file" "$@" + else + echo "Re-running $0 $extra_args $@" + ac_read_git_config=true exec "$0" $extra_args "$@" + fi fi fi fi diff --git a/tools/git-dev-options.sh b/tools/git-dev-options.sh index 21e60f50f2..41925f4321 100755 --- a/tools/git-dev-options.sh +++ b/tools/git-dev-options.sh @@ -15,16 +15,57 @@ # This script should have the same shebang as configure if test -e '.git' ; then : - extra_args=$(git config ocaml.configure 2>/dev/null) - if test -n "$extra_args" ; then : - if test -z "$ac_read_git_config" ; then : + if test -z "$ac_read_git_config" ; then : + extra_args=$(git config ocaml.configure 2>/dev/null) + extended_cache=$(git config ocaml.configure-cache 2>/dev/null) + cache_file= + + # If ocaml.configure-cache is set, parse the command-line for the --host + # option, in order to determine the name of the cache file. + if test -n "$extended_cache" ; then : + echo "Detected Git configuration option ocaml.configure-cache set to \ +\"$extended_cache\"" + dashdash= + prev= + host=default + # The logic here is pretty borrowed from autoconf's + for option in $extra_args "$@" + do + if test -n "$prev" ; then : + host=$option + continue + fi + + case $dashdash$option in + --) + dashdash=yes ;; + -host | --host | --hos | --ho) + prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + case $option in + *=?*) host=$(expr "X$option" : '[^=]*=\(.*\)') ;; + *=) host= ;; + esac ;; + esac + done + cache_file="`dirname "$0"`/$extended_cache/ocaml-$host.cache" + fi + + # If either option has a value, re-invoke configure + if test -n "$extra_args$cache_file" ; then : echo "Detected Git configuration option ocaml.configure set to \ \"$extra_args\"" # Too much effort to get the echo to show appropriate quoting - the # invocation itself intentionally quotes $0 and passes $@ exactly as given # but allows a single expansion of ocaml.configure - echo "Re-running $0 $extra_args $@" - ac_read_git_config=true exec "$0" $extra_args "$@" + if test -n "$cache_file" ; then : + echo "Re-running $0 $extra_args --cache-file \"$cache_file\" $@" + ac_read_git_config=true exec "$0" $extra_args \ + --cache-file "$cache_file" "$@" + else + echo "Re-running $0 $extra_args $@" + ac_read_git_config=true exec "$0" $extra_args "$@" + fi fi fi fi From dbd717e817307dc6a527dd54cc1c9765b30cfad2 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Tue, 8 Oct 2019 19:15:33 +0200 Subject: [PATCH 9/9] update typing/TODO.md --- typing/TODO.md | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/typing/TODO.md b/typing/TODO.md index 4b55995829..5b7c5e14d9 100644 --- a/typing/TODO.md +++ b/typing/TODO.md @@ -24,6 +24,17 @@ everyone to get an idea of planned tasks, refine them through Pull Requests, suggest more cleanups, or even start working on specific tasks (ideally after discussing it first with maintainers). +# Code smells + +- global mutable state +- poor data representation +- avoid constructing a parsetree locally + (methods build a piece of AST with a self argument + with a *-using name to avoid conflicts; #row, etc.) +- avoid magic string literals + +# TODO List + Not all ideas have been thoroughly discussed, and there might not be a consensus for all of them. @@ -51,8 +62,15 @@ consensus for all of them. (be careful about memory leaks with the naive approach of representing links with a persistent heap). + Modest version of the proposal: have an explicit indirection layer + (type_expr Unode.t) + for nodes in the union-find structure. Efficiency cost? + - Make the logic for record/constructor disambiguation more readable. + (Jacques should write a specification, and then we could try + to make the implementation easier for others to understand.) + - Tidy up destructive substitution. - Get rid of syntactic encodings (generating Parsetree fragments @@ -62,6 +80,7 @@ consensus for all of them. magic "internal" names which should be avoided. - Get rid of -annot. + (see Nicolás' PR) - Consider storing warning settings (+other context) as part of `Env.t`? @@ -71,9 +90,15 @@ consensus for all of them. - Introduce a notion of syntactic "path-like location" to point to allow pointing to AST fragments, and use that to implement "unused" warnings in a less invasive and less imperative way. + (See Thomas' PR) - Deprecate -nolabels, or even get rid of it? + (We could even stop supporting unlabeled full applications. + First turn on the warning by default.) - Using e.g. bisect_ppx, monitor coverage of the typechecker implementation while running the testsuite, and expand the testsuite and/or kill dead code in the typechecker to increase coverage ratio. + (Partially done by Oxana's Outreachy internship. + See PR#8874. + Ask Florian Angeletti and Sébastien Hinderer about the current state.)