root/src/comp.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. init_gccjit_functions
  2. load_gccjit_if_necessary
  3. ATTRIBUTE_FORMAT_PRINTF
  4. comp_hash_string
  5. comp_hash_source_file
  6. DEFUN
  7. hash_native_abi
  8. freloc_check_fill
  9. bcall0
  10. retrive_block
  11. declare_block
  12. emit_mvar_lval
  13. register_emitter
  14. obj_to_reloc
  15. emit_comment
  16. declare_imported_func
  17. emit_call
  18. emit_call_ref
  19. emit_cond_jump
  20. type_to_cast_index
  21. emit_coerce
  22. emit_binary_op
  23. emit_rvalue_from_long_long
  24. emit_rvalue_from_emacs_uint
  25. emit_rvalue_from_emacs_int
  26. emit_rvalue_from_lisp_word_tag
  27. emit_rvalue_from_lisp_word
  28. emit_rvalue_from_lisp_obj
  29. emit_ptr_arithmetic
  30. emit_XLI
  31. emit_XLP
  32. emit_XUNTAG
  33. emit_XCONS
  34. emit_BASE_EQ
  35. emit_AND
  36. emit_OR
  37. emit_TAGGEDP
  38. emit_VECTORLIKEP
  39. emit_CONSP
  40. emit_BARE_SYMBOL_P
  41. emit_SYMBOL_WITH_POS_P
  42. emit_SYMBOL_WITH_POS_SYM
  43. emit_EQ
  44. emit_FLOATP
  45. emit_BIGNUMP
  46. emit_FIXNUMP
  47. emit_XFIXNUM
  48. emit_INTEGERP
  49. emit_NUMBERP
  50. emit_make_fixnum_LSB_TAG
  51. emit_make_fixnum_MSB_TAG
  52. emit_make_fixnum
  53. emit_lisp_obj_reloc_lval
  54. emit_lisp_obj_rval
  55. emit_NILP
  56. emit_XCAR
  57. emit_lval_XCAR
  58. emit_XCDR
  59. emit_lval_XCDR
  60. emit_CHECK_CONS
  61. emit_CHECK_SYMBOL_WITH_POS
  62. emit_car_addr
  63. emit_cdr_addr
  64. emit_XSETCAR
  65. emit_XSETCDR
  66. emit_PURE_P
  67. emit_mvar_rval
  68. emit_frame_assignment
  69. emit_set_internal
  70. emit_simple_limple_call
  71. emit_simple_limple_call_lisp_ret
  72. emit_simple_limple_call_void_ret
  73. emit_limple_call
  74. emit_limple_call_ref
  75. emit_setjmp
  76. emit_limple_push_handler
  77. emit_limple_insn
  78. emit_call_with_type_hint
  79. emit_call2_with_type_hint
  80. emit_add1
  81. emit_sub1
  82. emit_negate
  83. emit_consp
  84. emit_car
  85. emit_cdr
  86. emit_setcar
  87. emit_setcdr
  88. emit_numperp
  89. emit_integerp
  90. emit_maybe_gc_or_quit
  91. emit_static_object
  92. declare_imported_data_relocs
  93. declare_imported_data
  94. declare_runtime_imported_funcs
  95. emit_ctxt_code
  96. define_lisp_cons
  97. define_lisp_symbol_with_position
  98. define_jmp_buf
  99. define_memcpy
  100. define_handler_struct
  101. define_thread_state_struct
  102. define_type_punning
  103. define_cast_from_to
  104. define_cast_functions
  105. define_CHECK_TYPE
  106. define_CAR_CDR
  107. define_setcar_setcdr
  108. define_add1_sub1
  109. define_negate
  110. define_PSEUDOVECTORP
  111. define_GET_SYMBOL_WITH_POSITION
  112. define_SYMBOL_WITH_POS_SYM
  113. define_CHECK_IMPURE
  114. define_maybe_gc_or_quit
  115. define_bool_to_lisp_obj
  116. declare_lex_function
  117. declare_function
  118. compile_function
  119. make_directory_wrapper
  120. make_directory_wrapper_1
  121. DEFUN
  122. DEFUN
  123. DEFUN
  124. DEFUN
  125. DEFUN
  126. add_driver_options
  127. add_compiler_options
  128. DEFUN
  129. DEFUN
  130. helper_unwind_protect
  131. helper_unbind_n
  132. helper_save_restriction
  133. helper_PSEUDOVECTOR_TYPEP_XUNTAG
  134. helper_GET_SYMBOL_WITH_POSITION
  135. return_nil
  136. directory_files_matching
  137. eln_load_path_final_clean_up
  138. register_native_comp_unit
  139. maybe_defer_native_compilation
  140. fixup_eln_load_path
  141. load_static_obj
  142. check_comp_unit_relocs
  143. unset_cu_load_ongoing
  144. load_comp_unit
  145. unload_comp_unit
  146. native_function_doc
  147. make_subr
  148. file_in_eln_sys_dir
  149. DEFUN
  150. syms_of_comp

     1 /* Compile Emacs Lisp into native code.
     2    Copyright (C) 2019-2023 Free Software Foundation, Inc.
     3 
     4 Author: Andrea Corallo <acorallo@gnu.org>
     5 
     6 This file is part of GNU Emacs.
     7 
     8 GNU Emacs is free software: you can redistribute it and/or modify
     9 it under the terms of the GNU General Public License as published by
    10 the Free Software Foundation, either version 3 of the License, or (at
    11 your option) any later version.
    12 
    13 GNU Emacs is distributed in the hope that it will be useful,
    14 but WITHOUT ANY WARRANTY; without even the implied warranty of
    15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16 GNU General Public License for more details.
    17 
    18 You should have received a copy of the GNU General Public License
    19 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    20 
    21 #include <config.h>
    22 
    23 #include "lisp.h"
    24 
    25 #ifdef HAVE_NATIVE_COMP
    26 
    27 #include <setjmp.h>
    28 #include <stdlib.h>
    29 #include <stdio.h>
    30 #include <signal.h>
    31 #include <libgccjit.h>
    32 #include <epaths.h>
    33 
    34 #include "puresize.h"
    35 #include "window.h"
    36 #include "dynlib.h"
    37 #include "buffer.h"
    38 #include "blockinput.h"
    39 #include "coding.h"
    40 #include "md5.h"
    41 #include "sysstdio.h"
    42 #include "zlib.h"
    43 
    44 
    45 /********************************/
    46 /* Dynamic loading of libgccjit */
    47 /********************************/
    48 
    49 #ifdef WINDOWSNT
    50 # include "w32common.h"
    51 
    52 #undef gcc_jit_block_add_assignment
    53 #undef gcc_jit_block_add_comment
    54 #undef gcc_jit_block_add_eval
    55 #undef gcc_jit_block_end_with_conditional
    56 #undef gcc_jit_block_end_with_jump
    57 #undef gcc_jit_block_end_with_return
    58 #undef gcc_jit_block_end_with_void_return
    59 #undef gcc_jit_context_acquire
    60 #undef gcc_jit_context_add_command_line_option
    61 #undef gcc_jit_context_add_driver_option
    62 #undef gcc_jit_context_compile_to_file
    63 #undef gcc_jit_context_dump_reproducer_to_file
    64 #undef gcc_jit_context_dump_to_file
    65 #undef gcc_jit_context_get_builtin_function
    66 #undef gcc_jit_context_get_first_error
    67 #undef gcc_jit_context_get_int_type
    68 #undef gcc_jit_context_get_type
    69 #undef gcc_jit_context_new_array_access
    70 #undef gcc_jit_context_new_array_type
    71 #undef gcc_jit_context_new_bitcast
    72 #undef gcc_jit_context_new_binary_op
    73 #undef gcc_jit_context_new_call
    74 #undef gcc_jit_context_new_call_through_ptr
    75 #undef gcc_jit_context_new_cast
    76 #undef gcc_jit_context_new_comparison
    77 #undef gcc_jit_context_new_field
    78 #undef gcc_jit_context_new_function
    79 #undef gcc_jit_context_new_function_ptr_type
    80 #undef gcc_jit_context_new_global
    81 #undef gcc_jit_context_new_opaque_struct
    82 #undef gcc_jit_context_new_param
    83 #undef gcc_jit_context_new_rvalue_from_int
    84 #undef gcc_jit_context_new_rvalue_from_long
    85 #undef gcc_jit_context_new_rvalue_from_ptr
    86 #undef gcc_jit_context_new_string_literal
    87 #undef gcc_jit_context_new_struct_type
    88 #undef gcc_jit_context_new_unary_op
    89 #undef gcc_jit_context_new_union_type
    90 #undef gcc_jit_context_release
    91 #undef gcc_jit_context_set_bool_option
    92 #undef gcc_jit_context_set_int_option
    93 #undef gcc_jit_context_set_logfile
    94 #undef gcc_jit_context_set_str_option
    95 #undef gcc_jit_function_get_param
    96 #undef gcc_jit_function_new_block
    97 #undef gcc_jit_function_new_local
    98 #undef gcc_jit_global_set_initializer
    99 #undef gcc_jit_lvalue_access_field
   100 #undef gcc_jit_lvalue_as_rvalue
   101 #undef gcc_jit_lvalue_get_address
   102 #undef gcc_jit_param_as_lvalue
   103 #undef gcc_jit_param_as_rvalue
   104 #undef gcc_jit_rvalue_access_field
   105 #undef gcc_jit_rvalue_dereference
   106 #undef gcc_jit_rvalue_dereference_field
   107 #undef gcc_jit_rvalue_get_type
   108 #undef gcc_jit_struct_as_type
   109 #undef gcc_jit_struct_set_fields
   110 #undef gcc_jit_type_get_const
   111 #undef gcc_jit_type_get_pointer
   112 #undef gcc_jit_type_is_pointer
   113 #undef gcc_jit_version_major
   114 #undef gcc_jit_version_minor
   115 #undef gcc_jit_version_patchlevel
   116 
   117 /* In alphabetical order */
   118 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_int,
   119             (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, int value));
   120 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_as_rvalue,
   121             (gcc_jit_lvalue *lvalue));
   122 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_rvalue_access_field,
   123             (gcc_jit_rvalue *struct_or_union, gcc_jit_location *loc,
   124              gcc_jit_field *field));
   125 DEF_DLL_FN (void, gcc_jit_block_add_comment,
   126             (gcc_jit_block *block, gcc_jit_location *loc, const char *text));
   127 DEF_DLL_FN (void, gcc_jit_context_release, (gcc_jit_context *ctxt));
   128 DEF_DLL_FN (const char *, gcc_jit_context_get_first_error,
   129             (gcc_jit_context *ctxt));
   130 DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block,
   131             (gcc_jit_function *func, const char *name));
   132 DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void));
   133 DEF_DLL_FN (void, gcc_jit_context_add_command_line_option,
   134             (gcc_jit_context *ctxt, const char *optname));
   135 DEF_DLL_FN (void, gcc_jit_context_add_driver_option,
   136             (gcc_jit_context *ctxt, const char *optname));
   137 DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field,
   138             (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type,
   139              const char *name));
   140 DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_get_builtin_function,
   141             (gcc_jit_context *ctxt, const char *name));
   142 DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_new_function,
   143             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   144              enum gcc_jit_function_kind kind, gcc_jit_type *return_type,
   145              const char *name, int num_params, gcc_jit_param **params,
   146              int is_variadic));
   147 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_array_access,
   148             (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_rvalue *ptr,
   149              gcc_jit_rvalue *index));
   150 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_global,
   151             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   152              enum gcc_jit_global_kind kind, gcc_jit_type *type,
   153              const char *name));
   154 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_function_new_local,
   155             (gcc_jit_function *func, gcc_jit_location *loc, gcc_jit_type *type,
   156              const char *name));
   157 #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer)
   158 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_global_set_initializer,
   159             (gcc_jit_lvalue *global, const void *blob, size_t num_bytes));
   160 #endif
   161 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_lvalue_access_field,
   162             (gcc_jit_lvalue *struct_or_union, gcc_jit_location *loc,
   163              gcc_jit_field *field));
   164 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_param_as_lvalue, (gcc_jit_param *param));
   165 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference,
   166             (gcc_jit_rvalue *rvalue, gcc_jit_location *loc));
   167 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference_field,
   168             (gcc_jit_rvalue *ptr, gcc_jit_location *loc, gcc_jit_field *field));
   169 DEF_DLL_FN (gcc_jit_param *, gcc_jit_context_new_param,
   170             (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type,
   171              const char *name));
   172 DEF_DLL_FN (gcc_jit_param *, gcc_jit_function_get_param,
   173             (gcc_jit_function *func, int index));
   174 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_binary_op,
   175             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   176              enum gcc_jit_binary_op op, gcc_jit_type *result_type,
   177              gcc_jit_rvalue *a, gcc_jit_rvalue *b));
   178 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call,
   179             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   180              gcc_jit_function *func, int numargs , gcc_jit_rvalue **args));
   181 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call_through_ptr,
   182             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   183              gcc_jit_rvalue *fn_ptr, int numargs, gcc_jit_rvalue **args));
   184 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_cast,
   185             (gcc_jit_context * ctxt, gcc_jit_location *loc,
   186              gcc_jit_rvalue *rvalue, gcc_jit_type *type));
   187 #ifdef LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast
   188 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_bitcast,
   189             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   190              gcc_jit_rvalue *rvalue, gcc_jit_type *type));
   191 #endif
   192 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_comparison,
   193             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   194              enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue *b));
   195 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long,
   196             (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value));
   197 #if LISP_WORDS_ARE_POINTERS
   198 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr,
   199             (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value));
   200 #endif
   201 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_string_literal,
   202             (gcc_jit_context *ctxt, const char *value));
   203 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op,
   204             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   205              enum gcc_jit_unary_op op, gcc_jit_type *result_type,
   206              gcc_jit_rvalue *rvalue));
   207 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_get_address,
   208             (gcc_jit_lvalue *lvalue, gcc_jit_location *loc));
   209 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_param_as_rvalue, (gcc_jit_param *param));
   210 DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_opaque_struct,
   211             (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name));
   212 DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_struct_type,
   213             (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name,
   214              int num_fields, gcc_jit_field **fields));
   215 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_int_type,
   216             (gcc_jit_context *ctxt, int num_bytes, int is_signed));
   217 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_type,
   218             (gcc_jit_context *ctxt, enum gcc_jit_types type_));
   219 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_array_type,
   220             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   221              gcc_jit_type *element_type, int num_elements));
   222 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_function_ptr_type,
   223             (gcc_jit_context *ctxt, gcc_jit_location *loc,
   224              gcc_jit_type *return_type, int num_params,
   225              gcc_jit_type **param_types, int is_variadic));
   226 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_union_type,
   227             (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name,
   228              int num_fields, gcc_jit_field **fields));
   229 DEF_DLL_FN (gcc_jit_type *, gcc_jit_rvalue_get_type, (gcc_jit_rvalue *rvalue));
   230 DEF_DLL_FN (gcc_jit_type *, gcc_jit_struct_as_type,
   231             (gcc_jit_struct *struct_type));
   232 DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_const, (gcc_jit_type *type));
   233 DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type));
   234 #ifdef LIBGCCJIT_HAVE_REFLECTION
   235 DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_is_pointer, (gcc_jit_type *type));
   236 #endif
   237 DEF_DLL_FN (void, gcc_jit_block_add_assignment,
   238             (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue,
   239              gcc_jit_rvalue *rvalue));
   240 DEF_DLL_FN (void, gcc_jit_block_add_eval,
   241             (gcc_jit_block *block, gcc_jit_location *loc,
   242              gcc_jit_rvalue *rvalue));
   243 DEF_DLL_FN (void, gcc_jit_block_end_with_conditional,
   244             (gcc_jit_block *block, gcc_jit_location *loc,
   245              gcc_jit_rvalue *boolval, gcc_jit_block *on_true,
   246              gcc_jit_block *on_false));
   247 DEF_DLL_FN (void, gcc_jit_block_end_with_jump,
   248             (gcc_jit_block *block, gcc_jit_location *loc,
   249              gcc_jit_block *target));
   250 DEF_DLL_FN (void, gcc_jit_block_end_with_return,
   251             (gcc_jit_block *block, gcc_jit_location *loc,
   252              gcc_jit_rvalue *rvalue));
   253 DEF_DLL_FN (void, gcc_jit_block_end_with_void_return,
   254             (gcc_jit_block *block, gcc_jit_location *loc));
   255 DEF_DLL_FN (void, gcc_jit_context_compile_to_file,
   256             (gcc_jit_context *ctxt, enum gcc_jit_output_kind output_kind,
   257              const char *output_path));
   258 DEF_DLL_FN (void, gcc_jit_context_dump_reproducer_to_file,
   259             (gcc_jit_context *ctxt, const char *path));
   260 DEF_DLL_FN (void, gcc_jit_context_dump_to_file,
   261             (gcc_jit_context *ctxt, const char *path, int update_locations));
   262 DEF_DLL_FN (void, gcc_jit_context_set_bool_option,
   263             (gcc_jit_context *ctxt, enum gcc_jit_bool_option opt, int value));
   264 DEF_DLL_FN (void, gcc_jit_context_set_int_option,
   265             (gcc_jit_context *ctxt, enum gcc_jit_int_option opt, int value));
   266 DEF_DLL_FN (void, gcc_jit_context_set_logfile,
   267             (gcc_jit_context *ctxt, FILE *logfile, int flags, int verbosity));
   268 DEF_DLL_FN (void, gcc_jit_context_set_str_option,
   269             (gcc_jit_context *ctxt, enum gcc_jit_str_option opt,
   270              const char *value));
   271 DEF_DLL_FN (void, gcc_jit_struct_set_fields,
   272             (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields,
   273              gcc_jit_field **fields));
   274 #if defined (LIBGCCJIT_HAVE_gcc_jit_version)
   275 DEF_DLL_FN (int, gcc_jit_version_major, (void));
   276 DEF_DLL_FN (int, gcc_jit_version_minor, (void));
   277 DEF_DLL_FN (int, gcc_jit_version_patchlevel, (void));
   278 #endif
   279 
   280 static bool
   281 init_gccjit_functions (void)
   282 {
   283   HMODULE library = w32_delayed_load (Qgccjit);
   284 
   285   if (!library)
   286     return false;
   287 
   288   /* In alphabetical order */
   289   LOAD_DLL_FN (library, gcc_jit_block_add_assignment);
   290   LOAD_DLL_FN (library, gcc_jit_block_add_comment);
   291   LOAD_DLL_FN (library, gcc_jit_block_add_eval);
   292   LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional);
   293   LOAD_DLL_FN (library, gcc_jit_block_end_with_jump);
   294   LOAD_DLL_FN (library, gcc_jit_block_end_with_return);
   295   LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return);
   296   LOAD_DLL_FN (library, gcc_jit_context_acquire);
   297   LOAD_DLL_FN (library, gcc_jit_context_compile_to_file);
   298   LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file);
   299   LOAD_DLL_FN (library, gcc_jit_context_dump_to_file);
   300   LOAD_DLL_FN (library, gcc_jit_context_get_builtin_function);
   301   LOAD_DLL_FN (library, gcc_jit_context_get_first_error);
   302   LOAD_DLL_FN (library, gcc_jit_context_get_int_type);
   303   LOAD_DLL_FN (library, gcc_jit_context_get_type);
   304   LOAD_DLL_FN (library, gcc_jit_context_new_array_access);
   305   LOAD_DLL_FN (library, gcc_jit_context_new_array_type);
   306 #ifdef LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast
   307   LOAD_DLL_FN (library, gcc_jit_context_new_bitcast);
   308 #endif
   309   LOAD_DLL_FN (library, gcc_jit_context_new_binary_op);
   310   LOAD_DLL_FN (library, gcc_jit_context_new_call);
   311   LOAD_DLL_FN (library, gcc_jit_context_new_call_through_ptr);
   312   LOAD_DLL_FN (library, gcc_jit_context_new_cast);
   313   LOAD_DLL_FN (library, gcc_jit_context_new_comparison);
   314   LOAD_DLL_FN (library, gcc_jit_context_new_field);
   315   LOAD_DLL_FN (library, gcc_jit_context_new_function);
   316   LOAD_DLL_FN (library, gcc_jit_context_new_function_ptr_type);
   317   LOAD_DLL_FN (library, gcc_jit_context_new_global);
   318   LOAD_DLL_FN (library, gcc_jit_context_new_opaque_struct);
   319   LOAD_DLL_FN (library, gcc_jit_context_new_param);
   320   LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int);
   321   LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long);
   322 #if LISP_WORDS_ARE_POINTERS
   323   LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr);
   324 #endif
   325   LOAD_DLL_FN (library, gcc_jit_context_new_string_literal);
   326   LOAD_DLL_FN (library, gcc_jit_context_new_struct_type);
   327   LOAD_DLL_FN (library, gcc_jit_context_new_unary_op);
   328   LOAD_DLL_FN (library, gcc_jit_context_new_union_type);
   329   LOAD_DLL_FN (library, gcc_jit_context_release);
   330   LOAD_DLL_FN (library, gcc_jit_context_set_bool_option);
   331   LOAD_DLL_FN (library, gcc_jit_context_set_int_option);
   332   LOAD_DLL_FN (library, gcc_jit_context_set_logfile);
   333   LOAD_DLL_FN (library, gcc_jit_context_set_str_option);
   334   LOAD_DLL_FN (library, gcc_jit_function_get_param);
   335   LOAD_DLL_FN (library, gcc_jit_function_new_block);
   336   LOAD_DLL_FN (library, gcc_jit_function_new_local);
   337   LOAD_DLL_FN (library, gcc_jit_lvalue_access_field);
   338   LOAD_DLL_FN (library, gcc_jit_lvalue_as_rvalue);
   339   LOAD_DLL_FN (library, gcc_jit_lvalue_get_address);
   340   LOAD_DLL_FN (library, gcc_jit_param_as_lvalue);
   341   LOAD_DLL_FN (library, gcc_jit_param_as_rvalue);
   342   LOAD_DLL_FN (library, gcc_jit_rvalue_access_field);
   343   LOAD_DLL_FN (library, gcc_jit_rvalue_dereference);
   344   LOAD_DLL_FN (library, gcc_jit_rvalue_dereference_field);
   345   LOAD_DLL_FN (library, gcc_jit_rvalue_get_type);
   346   LOAD_DLL_FN (library, gcc_jit_struct_as_type);
   347   LOAD_DLL_FN (library, gcc_jit_struct_set_fields);
   348   LOAD_DLL_FN (library, gcc_jit_type_get_const);
   349   LOAD_DLL_FN (library, gcc_jit_type_get_pointer);
   350 #ifdef LIBGCCJIT_HAVE_REFLECTION
   351   LOAD_DLL_FN (library, gcc_jit_type_is_pointer);
   352 #endif
   353   LOAD_DLL_FN_OPT (library, gcc_jit_context_add_command_line_option);
   354   LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option);
   355 #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer)
   356   LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer);
   357 #endif
   358 #if defined (LIBGCCJIT_HAVE_gcc_jit_version)
   359   LOAD_DLL_FN_OPT (library, gcc_jit_version_major);
   360   LOAD_DLL_FN_OPT (library, gcc_jit_version_minor);
   361   LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel);
   362 #endif
   363 
   364   return true;
   365 }
   366 
   367 /* In alphabetical order */
   368 #define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment
   369 #define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment
   370 #define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval
   371 #define gcc_jit_block_end_with_conditional fn_gcc_jit_block_end_with_conditional
   372 #define gcc_jit_block_end_with_jump fn_gcc_jit_block_end_with_jump
   373 #define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return
   374 #define gcc_jit_block_end_with_void_return fn_gcc_jit_block_end_with_void_return
   375 #define gcc_jit_context_acquire fn_gcc_jit_context_acquire
   376 #define gcc_jit_context_add_command_line_option fn_gcc_jit_context_add_command_line_option
   377 #define gcc_jit_context_add_driver_option fn_gcc_jit_context_add_driver_option
   378 #define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file
   379 #define gcc_jit_context_dump_reproducer_to_file fn_gcc_jit_context_dump_reproducer_to_file
   380 #define gcc_jit_context_dump_to_file fn_gcc_jit_context_dump_to_file
   381 #define gcc_jit_context_get_builtin_function fn_gcc_jit_context_get_builtin_function
   382 #define gcc_jit_context_get_first_error fn_gcc_jit_context_get_first_error
   383 #define gcc_jit_context_get_int_type fn_gcc_jit_context_get_int_type
   384 #define gcc_jit_context_get_type fn_gcc_jit_context_get_type
   385 #define gcc_jit_context_new_array_access fn_gcc_jit_context_new_array_access
   386 #define gcc_jit_context_new_array_type fn_gcc_jit_context_new_array_type
   387 #ifdef LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast
   388 # define gcc_jit_context_new_bitcast fn_gcc_jit_context_new_bitcast
   389 #endif
   390 #define gcc_jit_context_new_binary_op fn_gcc_jit_context_new_binary_op
   391 #define gcc_jit_context_new_call fn_gcc_jit_context_new_call
   392 #define gcc_jit_context_new_call_through_ptr fn_gcc_jit_context_new_call_through_ptr
   393 #define gcc_jit_context_new_cast fn_gcc_jit_context_new_cast
   394 #define gcc_jit_context_new_comparison fn_gcc_jit_context_new_comparison
   395 #define gcc_jit_context_new_field fn_gcc_jit_context_new_field
   396 #define gcc_jit_context_new_function fn_gcc_jit_context_new_function
   397 #define gcc_jit_context_new_function_ptr_type fn_gcc_jit_context_new_function_ptr_type
   398 #define gcc_jit_context_new_global fn_gcc_jit_context_new_global
   399 #define gcc_jit_context_new_opaque_struct fn_gcc_jit_context_new_opaque_struct
   400 #define gcc_jit_context_new_param fn_gcc_jit_context_new_param
   401 #define gcc_jit_context_new_rvalue_from_int fn_gcc_jit_context_new_rvalue_from_int
   402 #define gcc_jit_context_new_rvalue_from_long fn_gcc_jit_context_new_rvalue_from_long
   403 #if LISP_WORDS_ARE_POINTERS
   404 # define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr
   405 #endif
   406 #define gcc_jit_context_new_string_literal fn_gcc_jit_context_new_string_literal
   407 #define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type
   408 #define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op
   409 #define gcc_jit_context_new_union_type fn_gcc_jit_context_new_union_type
   410 #define gcc_jit_context_release fn_gcc_jit_context_release
   411 #define gcc_jit_context_set_bool_option fn_gcc_jit_context_set_bool_option
   412 #define gcc_jit_context_set_int_option fn_gcc_jit_context_set_int_option
   413 #define gcc_jit_context_set_logfile fn_gcc_jit_context_set_logfile
   414 #define gcc_jit_context_set_str_option fn_gcc_jit_context_set_str_option
   415 #define gcc_jit_function_get_param fn_gcc_jit_function_get_param
   416 #define gcc_jit_function_new_block fn_gcc_jit_function_new_block
   417 #define gcc_jit_function_new_local fn_gcc_jit_function_new_local
   418 #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer)
   419  #define gcc_jit_global_set_initializer fn_gcc_jit_global_set_initializer
   420 #endif
   421 #define gcc_jit_lvalue_access_field fn_gcc_jit_lvalue_access_field
   422 #define gcc_jit_lvalue_as_rvalue fn_gcc_jit_lvalue_as_rvalue
   423 #define gcc_jit_lvalue_get_address fn_gcc_jit_lvalue_get_address
   424 #define gcc_jit_param_as_lvalue fn_gcc_jit_param_as_lvalue
   425 #define gcc_jit_param_as_rvalue fn_gcc_jit_param_as_rvalue
   426 #define gcc_jit_rvalue_access_field fn_gcc_jit_rvalue_access_field
   427 #define gcc_jit_rvalue_dereference fn_gcc_jit_rvalue_dereference
   428 #define gcc_jit_rvalue_dereference_field fn_gcc_jit_rvalue_dereference_field
   429 #define gcc_jit_rvalue_get_type fn_gcc_jit_rvalue_get_type
   430 #define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type
   431 #define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields
   432 #ifdef LIBGCCJIT_HAVE_REFLECTION
   433 # define gcc_jit_type_is_pointer fn_gcc_jit_type_is_pointer
   434 #endif
   435 #define gcc_jit_type_get_const fn_gcc_jit_type_get_const
   436 #define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer
   437 #if defined (LIBGCCJIT_HAVE_gcc_jit_version)
   438  #define gcc_jit_version_major fn_gcc_jit_version_major
   439  #define gcc_jit_version_minor fn_gcc_jit_version_minor
   440  #define gcc_jit_version_patchlevel fn_gcc_jit_version_patchlevel
   441 #endif
   442 
   443 #endif
   444 
   445 static bool
   446 load_gccjit_if_necessary (bool mandatory)
   447 {
   448 #ifdef WINDOWSNT
   449   static bool tried_to_initialize_once;
   450   static bool gccjit_initialized;
   451 
   452   if (!tried_to_initialize_once)
   453     {
   454       tried_to_initialize_once = true;
   455       Lisp_Object status;
   456       gccjit_initialized = init_gccjit_functions ();
   457       status = gccjit_initialized ? Qt : Qnil;
   458       Vlibrary_cache = Fcons (Fcons (Qgccjit, status), Vlibrary_cache);
   459     }
   460 
   461   if (mandatory && !gccjit_initialized)
   462     xsignal1 (Qnative_compiler_error, build_string ("libgccjit not found"));
   463 
   464   return gccjit_initialized;
   465 #else
   466   return true;
   467 #endif
   468 }
   469 
   470 
   471 /* Increase this number to force a new Vcomp_abi_hash to be generated.  */
   472 #define ABI_VERSION "5"
   473 
   474 /* Length of the hashes used for eln file naming.  */
   475 #define HASH_LENGTH 8
   476 
   477 /* C symbols emitted for the load relocation mechanism.  */
   478 #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc"
   479 #define F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM "f_symbols_with_pos_enabled_reloc"
   480 #define PURE_RELOC_SYM "pure_reloc"
   481 #define DATA_RELOC_SYM "d_reloc"
   482 #define DATA_RELOC_IMPURE_SYM "d_reloc_imp"
   483 #define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph"
   484 
   485 #define FUNC_LINK_TABLE_SYM "freloc_link_table"
   486 #define LINK_TABLE_HASH_SYM "freloc_hash"
   487 #define COMP_UNIT_SYM "comp_unit"
   488 #define TEXT_DATA_RELOC_SYM "text_data_reloc"
   489 #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp"
   490 #define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph"
   491 
   492 #define TEXT_OPTIM_QLY_SYM "text_optim_qly"
   493 #define TEXT_FDOC_SYM "text_data_fdoc"
   494 
   495 #define STR_VALUE(s) #s
   496 #define STR(s) STR_VALUE (s)
   497 
   498 #define FIRST(x)                                \
   499   XCAR(x)
   500 #define SECOND(x)                               \
   501   XCAR (XCDR (x))
   502 #define THIRD(x)                                \
   503   XCAR (XCDR (XCDR (x)))
   504 
   505 #if 0   /* unused for now */
   506 /* Like call0 but stringify and intern.  */
   507 #define CALL0I(fun)                             \
   508   CALLN (Ffuncall, intern_c_string (STR (fun)))
   509 #endif
   510 
   511 /* Like call1 but stringify and intern.  */
   512 #define CALL1I(fun, arg)                                \
   513   CALLN (Ffuncall, intern_c_string (STR (fun)), arg)
   514 
   515 /* Like call2 but stringify and intern.  */
   516 #define CALL2I(fun, arg1, arg2)                         \
   517   CALLN (Ffuncall, intern_c_string (STR (fun)), arg1, arg2)
   518 
   519 /* Like call4 but stringify and intern.  */
   520 #define CALL4I(fun, arg1, arg2, arg3, arg4)                             \
   521   CALLN (Ffuncall, intern_c_string (STR (fun)), arg1, arg2, arg3, arg4)
   522 
   523 #define DECL_BLOCK(name, func)                          \
   524   gcc_jit_block *(name) =                               \
   525     gcc_jit_function_new_block ((func), STR (name))
   526 
   527 #ifndef WINDOWSNT
   528 # ifdef HAVE__SETJMP
   529 #  define SETJMP _setjmp
   530 # else
   531 #  define SETJMP setjmp
   532 # endif
   533 #else
   534 /* snippet from MINGW-64 setjmp.h */
   535 # define SETJMP _setjmp
   536 #endif
   537 #define SETJMP_NAME SETJMP
   538 
   539 /* Max number function importable by native compiled code.  */
   540 #define F_RELOC_MAX_SIZE 1600
   541 
   542 typedef struct {
   543   void *link_table[F_RELOC_MAX_SIZE];
   544   ptrdiff_t size;
   545 } f_reloc_t;
   546 
   547 static f_reloc_t freloc;
   548 
   549 #ifndef LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast
   550 # define NUM_CAST_TYPES 15
   551 #endif
   552 
   553 typedef struct {
   554   EMACS_INT len;
   555   gcc_jit_rvalue *r_val;
   556 } reloc_array_t;
   557 
   558 /* C side of the compiler context.  */
   559 
   560 typedef struct {
   561   EMACS_INT speed;
   562   EMACS_INT debug;
   563   Lisp_Object compiler_options;
   564   Lisp_Object driver_options;
   565   gcc_jit_context *ctxt;
   566   gcc_jit_type *void_type;
   567   gcc_jit_type *bool_type;
   568   gcc_jit_type *char_type;
   569   gcc_jit_type *int_type;
   570   gcc_jit_type *unsigned_type;
   571   gcc_jit_type *long_type;
   572   gcc_jit_type *unsigned_long_type;
   573   gcc_jit_type *long_long_type;
   574   gcc_jit_type *unsigned_long_long_type;
   575   gcc_jit_type *emacs_int_type;
   576   gcc_jit_type *emacs_uint_type;
   577   gcc_jit_type *void_ptr_type;
   578   gcc_jit_type *bool_ptr_type;
   579   gcc_jit_type *char_ptr_type;
   580   gcc_jit_type *ptrdiff_type;
   581   gcc_jit_type *uintptr_type;
   582   gcc_jit_type *size_t_type;
   583   gcc_jit_type *lisp_word_type;
   584   gcc_jit_type *lisp_word_tag_type;
   585 #ifdef LISP_OBJECT_IS_STRUCT
   586   gcc_jit_field *lisp_obj_i;
   587   gcc_jit_struct *lisp_obj_s;
   588 #endif
   589   gcc_jit_type *lisp_obj_type;
   590   gcc_jit_type *lisp_obj_ptr_type;
   591   /* struct Lisp_Cons */
   592   gcc_jit_struct *lisp_cons_s;
   593   gcc_jit_field *lisp_cons_u;
   594   gcc_jit_field *lisp_cons_u_s;
   595   gcc_jit_field *lisp_cons_u_s_car;
   596   gcc_jit_field *lisp_cons_u_s_u;
   597   gcc_jit_field *lisp_cons_u_s_u_cdr;
   598   gcc_jit_type *lisp_cons_type;
   599   gcc_jit_type *lisp_cons_ptr_type;
   600   /* struct Lisp_Symbol_With_Position */
   601   gcc_jit_rvalue *f_symbols_with_pos_enabled_ref;
   602   gcc_jit_struct *lisp_symbol_with_position;
   603   gcc_jit_field *lisp_symbol_with_position_header;
   604   gcc_jit_field *lisp_symbol_with_position_sym;
   605   gcc_jit_field *lisp_symbol_with_position_pos;
   606   gcc_jit_type *lisp_symbol_with_position_type;
   607   gcc_jit_type *lisp_symbol_with_position_ptr_type;
   608   gcc_jit_function *get_symbol_with_position;
   609   gcc_jit_function *symbol_with_pos_sym;
   610   /* struct jmp_buf.  */
   611   gcc_jit_struct *jmp_buf_s;
   612   /* struct handler.  */
   613   gcc_jit_struct *handler_s;
   614   gcc_jit_field *handler_jmp_field;
   615   gcc_jit_field *handler_val_field;
   616   gcc_jit_field *handler_next_field;
   617   gcc_jit_type *handler_ptr_type;
   618   gcc_jit_lvalue *loc_handler;
   619   /* struct thread_state.  */
   620   gcc_jit_struct *thread_state_s;
   621   gcc_jit_field *m_handlerlist;
   622   gcc_jit_type *thread_state_ptr_type;
   623   gcc_jit_rvalue *current_thread_ref;
   624   /* Other globals.  */
   625   gcc_jit_rvalue *pure_ptr;
   626 #ifndef LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast
   627   /* This version of libgccjit has really limited support for casting
   628      therefore this union will be used for the scope.  */
   629   gcc_jit_type *cast_union_type;
   630   gcc_jit_function *cast_functions_from_to[NUM_CAST_TYPES][NUM_CAST_TYPES];
   631   gcc_jit_function *cast_ptr_to_int;
   632   gcc_jit_function *cast_int_to_ptr;
   633   gcc_jit_type *cast_types[NUM_CAST_TYPES];
   634 #endif
   635   gcc_jit_function *func; /* Current function being compiled.  */
   636   bool func_has_non_local; /* From comp-func has-non-local slot.  */
   637   EMACS_INT func_speed; /* From comp-func speed slot.  */
   638   gcc_jit_block *block;  /* Current basic block being compiled.  */
   639   gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch).  */
   640   ptrdiff_t frame_size; /* Size of the following array in elements. */
   641   gcc_jit_lvalue **frame; /* Frame slot n -> gcc_jit_lvalue *.  */
   642   gcc_jit_rvalue *zero;
   643   gcc_jit_rvalue *one;
   644   gcc_jit_rvalue *inttypebits;
   645   gcc_jit_rvalue *lisp_int0;
   646   gcc_jit_function *pseudovectorp;
   647   gcc_jit_function *bool_to_lisp_obj;
   648   gcc_jit_function *add1;
   649   gcc_jit_function *sub1;
   650   gcc_jit_function *negate;
   651   gcc_jit_function *car;
   652   gcc_jit_function *cdr;
   653   gcc_jit_function *setcar;
   654   gcc_jit_function *setcdr;
   655   gcc_jit_function *check_type;
   656   gcc_jit_function *check_impure;
   657   gcc_jit_function *maybe_gc_or_quit;
   658   Lisp_Object func_blocks_h; /* blk_name -> gcc_block.  */
   659   Lisp_Object exported_funcs_h; /* c-func-name -> gcc_jit_function *.  */
   660   Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field.  */
   661   Lisp_Object emitter_dispatcher;
   662   /* Synthesized struct holding data relocs.  */
   663   reloc_array_t data_relocs;
   664   /* Same as before but can't go in pure space. */
   665   reloc_array_t data_relocs_impure;
   666   /* Same as before but content does not survive load phase. */
   667   reloc_array_t data_relocs_ephemeral;
   668   /* Global structure holding function relocations.  */
   669   gcc_jit_lvalue *func_relocs;
   670   gcc_jit_type *func_relocs_ptr_type;
   671   /* Pointer to this structure local to each function.  */
   672   gcc_jit_lvalue *func_relocs_local;
   673   gcc_jit_function *memcpy;
   674   Lisp_Object d_default_idx;
   675   Lisp_Object d_impure_idx;
   676   Lisp_Object d_ephemeral_idx;
   677 } comp_t;
   678 
   679 static comp_t comp;
   680 
   681 static FILE *logfile;
   682 
   683 /* This is used for serialized objects by the reload mechanism.  */
   684 typedef struct {
   685   ptrdiff_t len;
   686   char data[];
   687 } static_obj_t;
   688 
   689 typedef struct {
   690   reloc_array_t array;
   691   gcc_jit_rvalue *idx;
   692 } imm_reloc_t;
   693 
   694 
   695 /*
   696    Helper functions called by the run-time.
   697 */
   698 
   699 static void helper_unwind_protect (Lisp_Object);
   700 static Lisp_Object helper_unbind_n (Lisp_Object);
   701 static void helper_save_restriction (void);
   702 static bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object, enum pvec_type);
   703 static struct Lisp_Symbol_With_Pos *
   704 helper_GET_SYMBOL_WITH_POSITION (Lisp_Object);
   705 
   706 /* Note: helper_link_table must match the list created by
   707    `declare_runtime_imported_funcs'.  */
   708 static void *helper_link_table[] =
   709   { wrong_type_argument,
   710     helper_PSEUDOVECTOR_TYPEP_XUNTAG,
   711     pure_write_error,
   712     push_handler,
   713     record_unwind_protect_excursion,
   714     helper_unbind_n,
   715     helper_save_restriction,
   716     helper_GET_SYMBOL_WITH_POSITION,
   717     record_unwind_current_buffer,
   718     set_internal,
   719     helper_unwind_protect,
   720     specbind,
   721     maybe_gc,
   722     maybe_quit };
   723 
   724 
   725 static char * ATTRIBUTE_FORMAT_PRINTF (1, 2)
   726 format_string (const char *format, ...)
   727 {
   728   static char scratch_area[512];
   729   va_list va;
   730   va_start (va, format);
   731   int res = vsnprintf (scratch_area, sizeof (scratch_area), format, va);
   732   if (res >= sizeof (scratch_area))
   733     {
   734       scratch_area[sizeof (scratch_area) - 4] = '.';
   735       scratch_area[sizeof (scratch_area) - 3] = '.';
   736       scratch_area[sizeof (scratch_area) - 2] = '.';
   737     }
   738   va_end (va);
   739   return scratch_area;
   740 }
   741 
   742 static Lisp_Object
   743 comp_hash_string (Lisp_Object string)
   744 {
   745   Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2);
   746   md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest));
   747   hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE);
   748 
   749   return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH));
   750 }
   751 
   752 static Lisp_Object
   753 comp_hash_source_file (Lisp_Object filename)
   754 {
   755   /* Can't use Finsert_file_contents + Fbuffer_hash as this is called
   756      by Fcomp_el_to_eln_filename too early during bootstrap.  */
   757   bool is_gz = suffix_p (filename, ".gz");
   758 #ifndef HAVE_ZLIB
   759   if (is_gz)
   760     xsignal2 (Qfile_notify_error,
   761               build_string ("Cannot natively compile compressed *.el files without zlib support"),
   762               filename);
   763 #endif
   764   Lisp_Object encoded_filename = ENCODE_FILE (filename);
   765   FILE *f = emacs_fopen (SSDATA (encoded_filename), is_gz ? "rb" : "r");
   766 
   767   if (!f)
   768     report_file_error ("Opening source file", filename);
   769 
   770   Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2);
   771 
   772 #ifdef HAVE_ZLIB
   773   int res = is_gz
   774     ? md5_gz_stream (f, SSDATA (digest))
   775     : md5_stream (f, SSDATA (digest));
   776 #else
   777   int res = md5_stream (f, SSDATA (digest));
   778 #endif
   779   fclose (f);
   780 
   781   if (res)
   782     xsignal2 (Qfile_notify_error, build_string ("hashing failed"), filename);
   783 
   784   hexbuf_digest (SSDATA (digest), SSDATA (digest), MD5_DIGEST_SIZE);
   785 
   786   return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH));
   787 }
   788 
   789 DEFUN ("comp--subr-signature", Fcomp__subr_signature,
   790        Scomp__subr_signature, 1, 1, 0,
   791        doc: /* Support function to hash_native_abi.
   792 For internal use.  */)
   793   (Lisp_Object subr)
   794 {
   795   return concat2 (Fsubr_name (subr),
   796                   Fprin1_to_string (Fsubr_arity (subr), Qnil, Qnil));
   797 }
   798 
   799 /* Produce a key hashing Vcomp_subr_list.  */
   800 
   801 void
   802 hash_native_abi (void)
   803 {
   804   /* Check runs once.  */
   805   eassert (NILP (Vcomp_abi_hash));
   806 
   807   Vcomp_abi_hash =
   808     comp_hash_string (
   809       concat3 (build_string (ABI_VERSION),
   810                concat3 (Vemacs_version, Vsystem_configuration,
   811                         Vsystem_configuration_options),
   812                Fmapconcat (intern_c_string ("comp--subr-signature"),
   813                            Vcomp_subr_list, build_string (""))));
   814 
   815   Lisp_Object version = Vemacs_version;
   816 
   817 #ifdef NS_SELF_CONTAINED
   818   /* MacOS self contained app bundles do not like having dots in the
   819      directory names under the Contents/Frameworks directory, so
   820      convert them to underscores.  */
   821   version = STRING_MULTIBYTE (Vemacs_version)
   822     ? make_uninit_multibyte_string (SCHARS (Vemacs_version),
   823                                     SBYTES (Vemacs_version))
   824     : make_uninit_string (SBYTES (Vemacs_version));
   825 
   826   const unsigned char *from = SDATA (Vemacs_version);
   827   unsigned char *to = SDATA (version);
   828 
   829   while (from < SDATA (Vemacs_version) + SBYTES (Vemacs_version))
   830     {
   831       unsigned char c = *from++;
   832 
   833       if (c == '.')
   834         c = '_';
   835 
   836       *to++ = c;
   837     }
   838 #endif
   839 
   840   Vcomp_native_version_dir =
   841     concat3 (version, build_string ("-"), Vcomp_abi_hash);
   842 }
   843 
   844 static void
   845 freloc_check_fill (void)
   846 {
   847   if (freloc.size)
   848     return;
   849 
   850   eassert (!NILP (Vcomp_subr_list));
   851 
   852   if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE)
   853     goto overflow;
   854   memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table));
   855   freloc.size = ARRAYELTS (helper_link_table);
   856 
   857   Lisp_Object subr_l = Vcomp_subr_list;
   858   FOR_EACH_TAIL (subr_l)
   859     {
   860       if (freloc.size == F_RELOC_MAX_SIZE)
   861         goto overflow;
   862       struct Lisp_Subr *subr = XSUBR (XCAR (subr_l));
   863       freloc.link_table[freloc.size] = subr->function.a0;
   864       freloc.size++;
   865     }
   866   return;
   867 
   868  overflow:
   869   fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE");
   870 }
   871 
   872 static void
   873 bcall0 (Lisp_Object f)
   874 {
   875   Ffuncall (1, &f);
   876 }
   877 
   878 static gcc_jit_block *
   879 retrive_block (Lisp_Object block_name)
   880 {
   881   Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil);
   882 
   883   if (NILP (value))
   884     xsignal2 (Qnative_ice, build_string ("missing basic block"), block_name);
   885 
   886   return (gcc_jit_block *) xmint_pointer (value);
   887 }
   888 
   889 static void
   890 declare_block (Lisp_Object block_name)
   891 {
   892   char *name_str = SSDATA (SYMBOL_NAME (block_name));
   893   gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str);
   894   Lisp_Object value = make_mint_ptr (block);
   895 
   896   if (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)))
   897     xsignal1 (Qnative_ice, build_string ("double basic block declaration"));
   898 
   899   Fputhash (block_name, value, comp.func_blocks_h);
   900 }
   901 
   902 static gcc_jit_lvalue *
   903 emit_mvar_lval (Lisp_Object mvar)
   904 {
   905   Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar);
   906 
   907   if (EQ (mvar_slot, Qscratch))
   908     {
   909       if (!comp.scratch)
   910         comp.scratch = gcc_jit_function_new_local (comp.func,
   911                                                    NULL,
   912                                                    comp.lisp_obj_type,
   913                                                    "scratch");
   914       return comp.scratch;
   915     }
   916 
   917   EMACS_INT slot_n = XFIXNUM (mvar_slot);
   918   eassert (slot_n < comp.frame_size);
   919   return comp.frame[slot_n];
   920 }
   921 
   922 static void
   923 register_emitter (Lisp_Object key, void *func)
   924 {
   925   Lisp_Object value = make_mint_ptr (func);
   926   Fputhash (key, value, comp.emitter_dispatcher);
   927 }
   928 
   929 static imm_reloc_t
   930 obj_to_reloc (Lisp_Object obj)
   931 {
   932   imm_reloc_t reloc;
   933   Lisp_Object idx;
   934 
   935   idx = Fgethash (obj, comp.d_default_idx, Qnil);
   936   if (!NILP (idx)) {
   937       reloc.array = comp.data_relocs;
   938       goto found;
   939   }
   940 
   941   idx = Fgethash (obj, comp.d_impure_idx, Qnil);
   942   if (!NILP (idx))
   943     {
   944       reloc.array = comp.data_relocs_impure;
   945       goto found;
   946     }
   947 
   948   idx = Fgethash (obj, comp.d_ephemeral_idx, Qnil);
   949   if (!NILP (idx))
   950     {
   951       reloc.array = comp.data_relocs_ephemeral;
   952       goto found;
   953     }
   954 
   955   xsignal1 (Qnative_ice,
   956             build_string ("can't find data in relocation containers"));
   957   assume (false);
   958 
   959  found:
   960   eassert (XFIXNUM (idx) < reloc.array.len);
   961   if (!FIXNUMP (idx))
   962     xsignal1 (Qnative_ice,
   963               build_string ("inconsistent data relocation container"));
   964   reloc.idx = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
   965                                                    comp.ptrdiff_type,
   966                                                    XFIXNUM (idx));
   967   return reloc;
   968 }
   969 
   970 static void
   971 emit_comment (const char *str)
   972 {
   973   if (comp.debug)
   974     gcc_jit_block_add_comment (comp.block,
   975                                NULL,
   976                                str);
   977 }
   978 
   979 /*
   980   Declare an imported function.
   981   When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed.
   982   When types is NULL args are assumed to be all Lisp_Objects.
   983 */
   984 static gcc_jit_field *
   985 declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type,
   986                        int nargs, gcc_jit_type **types)
   987 {
   988   USE_SAFE_ALLOCA;
   989   /* Don't want to declare the same function two times.  */
   990   if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil)))
   991     xsignal2 (Qnative_ice,
   992               build_string ("unexpected double function declaration"),
   993               subr_sym);
   994 
   995   if (nargs == MANY)
   996     {
   997       nargs = 2;
   998       types = SAFE_ALLOCA (nargs * sizeof (* types));
   999       types[0] = comp.ptrdiff_type;
  1000       types[1] = comp.lisp_obj_ptr_type;
  1001     }
  1002   else if (nargs == UNEVALLED)
  1003     {
  1004       nargs = 1;
  1005       types = SAFE_ALLOCA (nargs * sizeof (* types));
  1006       types[0] = comp.lisp_obj_type;
  1007     }
  1008   else if (!types)
  1009     {
  1010       types = SAFE_ALLOCA (nargs * sizeof (* types));
  1011       for (ptrdiff_t i = 0; i < nargs; i++)
  1012         types[i] = comp.lisp_obj_type;
  1013     }
  1014 
  1015   /* String containing the function ptr name.  */
  1016   Lisp_Object f_ptr_name =
  1017     CALLN (Ffuncall, intern_c_string ("comp-c-func-name"),
  1018            subr_sym, make_string ("R", 1));
  1019 
  1020   gcc_jit_type *f_ptr_type =
  1021     gcc_jit_type_get_const (
  1022       gcc_jit_context_new_function_ptr_type (comp.ctxt,
  1023                                              NULL,
  1024                                              ret_type,
  1025                                              nargs,
  1026                                              types,
  1027                                              0));
  1028   gcc_jit_field *field =
  1029     gcc_jit_context_new_field (comp.ctxt,
  1030                                NULL,
  1031                                f_ptr_type,
  1032                                SSDATA (f_ptr_name));
  1033 
  1034   Fputhash (subr_sym, make_mint_ptr (field), comp.imported_funcs_h);
  1035   SAFE_FREE ();
  1036   return field;
  1037 }
  1038 
  1039 /* Emit calls fetching from existing declarations.  */
  1040 
  1041 static gcc_jit_rvalue *
  1042 emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs,
  1043            gcc_jit_rvalue **args, bool direct)
  1044 {
  1045   Lisp_Object gcc_func =
  1046     Fgethash (func,
  1047               direct ? comp.exported_funcs_h : comp.imported_funcs_h,
  1048               Qnil);
  1049 
  1050   if (NILP (gcc_func))
  1051       xsignal2 (Qnative_ice,
  1052                 build_string ("missing function declaration"),
  1053                 func);
  1054 
  1055   if (direct)
  1056     {
  1057       emit_comment (format_string ("direct call to: %s",
  1058                                    SSDATA (func)));
  1059       return gcc_jit_context_new_call (comp.ctxt,
  1060                                        NULL,
  1061                                        xmint_pointer (gcc_func),
  1062                                        nargs,
  1063                                        args);
  1064     }
  1065   else
  1066     {
  1067       /* Inline functions so far don't have a local variable for
  1068          function reloc table so we fall back to the global one.  Even
  1069          if this is not aesthetic calling into C from open-code is
  1070          always a fallback and therefore not be performance critical.
  1071          To fix this could think do the inline our-self without
  1072          relying on GCC. */
  1073       gcc_jit_lvalue *f_ptr =
  1074         gcc_jit_rvalue_dereference_field (
  1075           gcc_jit_lvalue_as_rvalue (comp.func_relocs_local
  1076                                     ? comp.func_relocs_local
  1077                                     : comp.func_relocs),
  1078           NULL,
  1079           (gcc_jit_field *) xmint_pointer (gcc_func));
  1080 
  1081       if (!f_ptr)
  1082         xsignal2 (Qnative_ice,
  1083                   build_string ("missing function relocation"),
  1084                   func);
  1085       emit_comment (format_string ("calling subr: %s",
  1086                                    SSDATA (SYMBOL_NAME (func))));
  1087       return gcc_jit_context_new_call_through_ptr (comp.ctxt,
  1088                                                    NULL,
  1089                                                    gcc_jit_lvalue_as_rvalue (f_ptr),
  1090                                                    nargs,
  1091                                                    args);
  1092     }
  1093 }
  1094 
  1095 static gcc_jit_rvalue *
  1096 emit_call_ref (Lisp_Object func, ptrdiff_t nargs,
  1097                gcc_jit_lvalue *base_arg, bool direct)
  1098 {
  1099   gcc_jit_rvalue *args[] =
  1100     { gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  1101                                            comp.ptrdiff_type,
  1102                                            nargs),
  1103       gcc_jit_lvalue_get_address (base_arg, NULL) };
  1104   return emit_call (func, comp.lisp_obj_type, 2, args, direct);
  1105 }
  1106 
  1107 /* Close current basic block emitting a conditional.  */
  1108 
  1109 static void
  1110 emit_cond_jump (gcc_jit_rvalue *test,
  1111                 gcc_jit_block *then_target, gcc_jit_block *else_target)
  1112 {
  1113   if (gcc_jit_rvalue_get_type (test) == comp.bool_type)
  1114     gcc_jit_block_end_with_conditional (comp.block,
  1115                                       NULL,
  1116                                       test,
  1117                                       then_target,
  1118                                       else_target);
  1119   else
  1120     /* In case test is not bool we do a logical negation to obtain a bool as
  1121        result.  */
  1122     gcc_jit_block_end_with_conditional (
  1123       comp.block,
  1124       NULL,
  1125       gcc_jit_context_new_unary_op (comp.ctxt,
  1126                                     NULL,
  1127                                     GCC_JIT_UNARY_OP_LOGICAL_NEGATE,
  1128                                     comp.bool_type,
  1129                                     test),
  1130       else_target,
  1131       then_target);
  1132 
  1133 }
  1134 
  1135 #ifndef LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast
  1136 static int
  1137 type_to_cast_index (gcc_jit_type * type)
  1138 {
  1139   for (int i = 0; i < NUM_CAST_TYPES; ++i)
  1140     if (type == comp.cast_types[i])
  1141       return i;
  1142 
  1143   xsignal1 (Qnative_ice, build_string ("unsupported cast"));
  1144 }
  1145 #endif
  1146 
  1147 static gcc_jit_rvalue *
  1148 emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj)
  1149 {
  1150   gcc_jit_type *old_type = gcc_jit_rvalue_get_type (obj);
  1151 
  1152   if (new_type == old_type)
  1153     return obj;
  1154 
  1155 #ifdef LISP_OBJECT_IS_STRUCT
  1156   if (old_type == comp.lisp_obj_type)
  1157     {
  1158       gcc_jit_rvalue *lwordobj =
  1159         gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_i);
  1160       return emit_coerce (new_type, lwordobj);
  1161     }
  1162 
  1163   if (new_type == comp.lisp_obj_type)
  1164     {
  1165       gcc_jit_rvalue *lwordobj =
  1166         emit_coerce (comp.lisp_word_type, obj);
  1167 
  1168       static ptrdiff_t i;
  1169       gcc_jit_lvalue *tmp_s =
  1170         gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type,
  1171                                     format_string ("lisp_obj_%td", i++));
  1172 
  1173       gcc_jit_block_add_assignment (
  1174         comp.block, NULL,
  1175         gcc_jit_lvalue_access_field (tmp_s, NULL,
  1176                                      comp.lisp_obj_i),
  1177         lwordobj);
  1178       return gcc_jit_lvalue_as_rvalue (tmp_s);
  1179     }
  1180 #endif
  1181 
  1182 #ifdef LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast
  1183   bool old_is_ptr = gcc_jit_type_is_pointer (old_type) != NULL;
  1184   bool new_is_ptr = gcc_jit_type_is_pointer (new_type) != NULL;
  1185 
  1186   gcc_jit_rvalue *tmp = obj;
  1187 
  1188   /* `gcc_jit_context_new_bitcast` requires that the types being converted
  1189      between have the same layout and as such, doesn't allow converting
  1190      between an arbitrarily sized integer/boolean and a pointer. Casting it
  1191      to a uintptr/void* is still necessary, to ensure that it can be bitcast
  1192      into a (void *)/uintptr respectively.  */
  1193   if (old_is_ptr != new_is_ptr)
  1194     {
  1195       if (old_is_ptr)
  1196         {
  1197           tmp = gcc_jit_context_new_cast (comp.ctxt, NULL, tmp,
  1198                                           comp.void_ptr_type);
  1199           tmp = gcc_jit_context_new_bitcast (comp.ctxt, NULL, tmp,
  1200                                              comp.uintptr_type);
  1201         }
  1202       else
  1203         {
  1204           tmp = gcc_jit_context_new_cast (comp.ctxt, NULL, tmp,
  1205                                           comp.uintptr_type);
  1206           tmp = gcc_jit_context_new_bitcast (comp.ctxt, NULL, tmp,
  1207                                              comp.void_ptr_type);
  1208         }
  1209     }
  1210   return gcc_jit_context_new_cast (comp.ctxt, NULL, tmp, new_type);
  1211 
  1212 #else /* !LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast */
  1213 
  1214   int old_index = type_to_cast_index (old_type);
  1215   int new_index = type_to_cast_index (new_type);
  1216 
  1217   /* Lookup the appropriate cast function in the cast matrix.  */
  1218   return gcc_jit_context_new_call (comp.ctxt,
  1219                                    NULL,
  1220                                    comp.cast_functions_from_to
  1221                                    [old_index][new_index],
  1222                                    1, &obj);
  1223 #endif
  1224 }
  1225 
  1226 static gcc_jit_rvalue *
  1227 emit_binary_op (enum gcc_jit_binary_op op,
  1228                 gcc_jit_type *result_type,
  1229                 gcc_jit_rvalue *a, gcc_jit_rvalue *b)
  1230 {
  1231   /* FIXME Check here for possible UB.  */
  1232   return gcc_jit_context_new_binary_op (comp.ctxt, NULL,
  1233                                         op,
  1234                                         result_type,
  1235                                         emit_coerce (result_type, a),
  1236                                         emit_coerce (result_type, b));
  1237 }
  1238 
  1239 /* Should come with libgccjit.  */
  1240 
  1241 static gcc_jit_rvalue *
  1242 emit_rvalue_from_long_long (gcc_jit_type *type, long long n)
  1243 {
  1244   emit_comment (format_string ("emit long long: %lld", n));
  1245 
  1246   gcc_jit_rvalue *high =
  1247     gcc_jit_context_new_rvalue_from_long (comp.ctxt,
  1248                                           comp.unsigned_long_long_type,
  1249                                           (unsigned long long)n >> 32);
  1250   gcc_jit_rvalue *low =
  1251     emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
  1252                     comp.unsigned_long_long_type,
  1253                     emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
  1254                                     comp.unsigned_long_long_type,
  1255                                     gcc_jit_context_new_rvalue_from_long (
  1256                                       comp.ctxt,
  1257                                       comp.unsigned_long_long_type,
  1258                                       n),
  1259                                     gcc_jit_context_new_rvalue_from_int (
  1260                                       comp.ctxt,
  1261                                       comp.unsigned_long_long_type,
  1262                                       32)),
  1263                     gcc_jit_context_new_rvalue_from_int (
  1264                       comp.ctxt,
  1265                       comp.unsigned_long_long_type,
  1266                       32));
  1267 
  1268   return
  1269     emit_coerce (type,
  1270       emit_binary_op (
  1271         GCC_JIT_BINARY_OP_BITWISE_OR,
  1272         comp.unsigned_long_long_type,
  1273         emit_binary_op (
  1274           GCC_JIT_BINARY_OP_LSHIFT,
  1275           comp.unsigned_long_long_type,
  1276           high,
  1277           gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  1278                                                comp.unsigned_long_long_type,
  1279                                                32)),
  1280         low));
  1281 }
  1282 
  1283 static gcc_jit_rvalue *
  1284 emit_rvalue_from_emacs_uint (EMACS_UINT val)
  1285 {
  1286 #ifdef WIDE_EMACS_INT
  1287   if (val > ULONG_MAX)
  1288     return emit_rvalue_from_long_long (comp.emacs_uint_type, val);
  1289 #endif
  1290   return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
  1291                                                comp.emacs_uint_type,
  1292                                                val);
  1293 }
  1294 
  1295 static gcc_jit_rvalue *
  1296 emit_rvalue_from_emacs_int (EMACS_INT val)
  1297 {
  1298   if (val > LONG_MAX || val < LONG_MIN)
  1299     return emit_rvalue_from_long_long (comp.emacs_int_type, val);
  1300   else
  1301     return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
  1302                                                  comp.emacs_int_type, val);
  1303 }
  1304 
  1305 static gcc_jit_rvalue *
  1306 emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val)
  1307 {
  1308 #ifdef WIDE_EMACS_INT
  1309   if (val > ULONG_MAX)
  1310     return emit_rvalue_from_long_long (comp.lisp_word_tag_type, val);
  1311 #endif
  1312   return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
  1313                                                comp.lisp_word_tag_type,
  1314                                                val);
  1315 }
  1316 
  1317 static gcc_jit_rvalue *
  1318 emit_rvalue_from_lisp_word (Lisp_Word val)
  1319 {
  1320 #if LISP_WORDS_ARE_POINTERS
  1321   return gcc_jit_context_new_rvalue_from_ptr (comp.ctxt,
  1322                                               comp.lisp_word_type,
  1323                                               val);
  1324 #else
  1325   if (val > LONG_MAX || val < LONG_MIN)
  1326     return emit_rvalue_from_long_long (comp.lisp_word_type, val);
  1327   else
  1328     return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
  1329                                                  comp.lisp_word_type,
  1330                                                  val);
  1331 #endif
  1332 }
  1333 
  1334 static gcc_jit_rvalue *
  1335 emit_rvalue_from_lisp_obj (Lisp_Object obj)
  1336 {
  1337 #ifdef LISP_OBJECT_IS_STRUCT
  1338   return emit_coerce (comp.lisp_obj_type,
  1339                       emit_rvalue_from_lisp_word (obj.i));
  1340 #else
  1341   return emit_rvalue_from_lisp_word (obj);
  1342 #endif
  1343 }
  1344 
  1345 /*
  1346    Emit the equivalent of:
  1347    (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i)
  1348 */
  1349 
  1350 static gcc_jit_rvalue *
  1351 emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type,
  1352                      int size_of_ptr_ref, gcc_jit_rvalue *i)
  1353 {
  1354   emit_comment ("ptr_arithmetic");
  1355 
  1356   gcc_jit_rvalue *offset =
  1357     emit_binary_op (
  1358       GCC_JIT_BINARY_OP_MULT,
  1359       comp.uintptr_type,
  1360       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  1361                                            comp.uintptr_type,
  1362                                            size_of_ptr_ref),
  1363        i);
  1364 
  1365   return
  1366     emit_coerce (
  1367       ptr_type,
  1368       emit_binary_op (
  1369         GCC_JIT_BINARY_OP_PLUS,
  1370         comp.uintptr_type,
  1371         ptr,
  1372         offset));
  1373 }
  1374 
  1375 static gcc_jit_rvalue *
  1376 emit_XLI (gcc_jit_rvalue *obj)
  1377 {
  1378   emit_comment ("XLI");
  1379   return emit_coerce (comp.emacs_int_type, obj);
  1380 }
  1381 
  1382 static gcc_jit_rvalue *
  1383 emit_XLP (gcc_jit_rvalue *obj)
  1384 {
  1385   emit_comment ("XLP");
  1386 
  1387   return emit_coerce (comp.void_ptr_type, obj);
  1388 }
  1389 
  1390 static gcc_jit_rvalue *
  1391 emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag)
  1392 {
  1393   /* #define XUNTAG(a, type, ctype) ((ctype *)
  1394      ((char *) XLP (a) - LISP_WORD_TAG (type))) */
  1395   emit_comment ("XUNTAG");
  1396 
  1397   return emit_coerce (
  1398            gcc_jit_type_get_pointer (type),
  1399            emit_binary_op (
  1400              GCC_JIT_BINARY_OP_MINUS,
  1401              comp.uintptr_type,
  1402              emit_XLP (a),
  1403              emit_rvalue_from_lisp_word_tag (lisp_word_tag)));
  1404 }
  1405 
  1406 static gcc_jit_rvalue *
  1407 emit_XCONS (gcc_jit_rvalue *a)
  1408 {
  1409   emit_comment ("XCONS");
  1410 
  1411   return emit_XUNTAG (a,
  1412                       gcc_jit_struct_as_type (comp.lisp_cons_s),
  1413                       LISP_WORD_TAG (Lisp_Cons));
  1414 }
  1415 
  1416 static gcc_jit_rvalue *
  1417 emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
  1418 {
  1419   emit_comment ("BASE_EQ");
  1420 
  1421   return gcc_jit_context_new_comparison (
  1422            comp.ctxt,
  1423            NULL,
  1424            GCC_JIT_COMPARISON_EQ,
  1425            emit_XLI (x),
  1426            emit_XLI (y));
  1427 }
  1428 
  1429 static gcc_jit_rvalue *
  1430 emit_AND (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
  1431 {
  1432   return gcc_jit_context_new_binary_op (
  1433     comp.ctxt,
  1434     NULL,
  1435     GCC_JIT_BINARY_OP_LOGICAL_AND,
  1436     comp.bool_type,
  1437     x,
  1438     y);
  1439 }
  1440 
  1441 static gcc_jit_rvalue *
  1442 emit_OR (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
  1443 {
  1444   return gcc_jit_context_new_binary_op (
  1445     comp.ctxt,
  1446     NULL,
  1447     GCC_JIT_BINARY_OP_LOGICAL_OR,
  1448     comp.bool_type,
  1449     x,
  1450     y);
  1451 }
  1452 
  1453 static gcc_jit_rvalue *
  1454 emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag)
  1455 {
  1456    /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
  1457         - (unsigned) (tag)) \
  1458         & ((1 << GCTYPEBITS) - 1))) */
  1459   emit_comment ("TAGGEDP");
  1460 
  1461   gcc_jit_rvalue *sh_res =
  1462     emit_binary_op (
  1463       GCC_JIT_BINARY_OP_RSHIFT,
  1464       comp.emacs_int_type,
  1465       emit_XLI (obj),
  1466       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  1467                                            comp.emacs_int_type,
  1468                                            (USE_LSB_TAG ? 0 : VALBITS)));
  1469 
  1470   gcc_jit_rvalue *minus_res =
  1471     emit_binary_op (
  1472       GCC_JIT_BINARY_OP_MINUS,
  1473            comp.unsigned_type,
  1474            sh_res,
  1475            gcc_jit_context_new_rvalue_from_int (
  1476              comp.ctxt,
  1477              comp.unsigned_type,
  1478              tag));
  1479 
  1480   gcc_jit_rvalue *res =
  1481    gcc_jit_context_new_unary_op (
  1482      comp.ctxt,
  1483      NULL,
  1484      GCC_JIT_UNARY_OP_LOGICAL_NEGATE,
  1485      comp.int_type,
  1486      emit_binary_op (
  1487        GCC_JIT_BINARY_OP_BITWISE_AND,
  1488        comp.unsigned_type,
  1489        minus_res,
  1490        gcc_jit_context_new_rvalue_from_int (
  1491          comp.ctxt,
  1492          comp.unsigned_type,
  1493          ((1 << GCTYPEBITS) - 1))));
  1494 
  1495   return res;
  1496 }
  1497 
  1498 static gcc_jit_rvalue *
  1499 emit_VECTORLIKEP (gcc_jit_rvalue *obj)
  1500 {
  1501   emit_comment ("VECTORLIKEP");
  1502 
  1503   return emit_TAGGEDP (obj, Lisp_Vectorlike);
  1504 }
  1505 
  1506 static gcc_jit_rvalue *
  1507 emit_CONSP (gcc_jit_rvalue *obj)
  1508 {
  1509   emit_comment ("CONSP");
  1510 
  1511   return emit_TAGGEDP (obj, Lisp_Cons);
  1512 }
  1513 
  1514 static gcc_jit_rvalue *
  1515 emit_BARE_SYMBOL_P (gcc_jit_rvalue *obj)
  1516 {
  1517   emit_comment ("BARE_SYMBOL_P");
  1518 
  1519   return gcc_jit_context_new_cast (comp.ctxt,
  1520                                    NULL,
  1521                                    emit_TAGGEDP (obj, Lisp_Symbol),
  1522                                    comp.bool_type);
  1523 }
  1524 
  1525 static gcc_jit_rvalue *
  1526 emit_SYMBOL_WITH_POS_P (gcc_jit_rvalue *obj)
  1527 {
  1528   emit_comment ("SYMBOL_WITH_POS_P");
  1529 
  1530   gcc_jit_rvalue *args[] =
  1531     { obj,
  1532       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  1533                                            comp.int_type,
  1534                                            PVEC_SYMBOL_WITH_POS)
  1535     };
  1536 
  1537   return gcc_jit_context_new_call (comp.ctxt,
  1538                                    NULL,
  1539                                    comp.pseudovectorp,
  1540                                    2,
  1541                                    args);
  1542 }
  1543 
  1544 static gcc_jit_rvalue *
  1545 emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj)
  1546 {
  1547   emit_comment ("SYMBOL_WITH_POS_SYM");
  1548 
  1549   gcc_jit_rvalue *arg [] = { obj };
  1550   return gcc_jit_context_new_call (comp.ctxt,
  1551                                    NULL,
  1552                                    comp.symbol_with_pos_sym,
  1553                                    1,
  1554                                    arg);
  1555 }
  1556 
  1557 static gcc_jit_rvalue *
  1558 emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
  1559 {
  1560   return
  1561     emit_OR (
  1562       gcc_jit_context_new_comparison (
  1563         comp.ctxt, NULL,
  1564         GCC_JIT_COMPARISON_EQ,
  1565         emit_XLI (x), emit_XLI (y)),
  1566       emit_AND (
  1567         gcc_jit_lvalue_as_rvalue (
  1568           gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref,
  1569                                       NULL)),
  1570         emit_OR (
  1571           emit_AND (
  1572             emit_SYMBOL_WITH_POS_P (x),
  1573             emit_OR (
  1574               emit_AND (
  1575                 emit_SYMBOL_WITH_POS_P (y),
  1576                 emit_BASE_EQ (
  1577                   emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
  1578                   emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))),
  1579               emit_AND (
  1580                 emit_BARE_SYMBOL_P (y),
  1581                 emit_BASE_EQ (
  1582                   emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
  1583                   emit_XLI (y))))),
  1584           emit_AND (
  1585             emit_BARE_SYMBOL_P (x),
  1586             emit_AND (
  1587               emit_SYMBOL_WITH_POS_P (y),
  1588               emit_BASE_EQ (
  1589                 emit_XLI (x),
  1590                 emit_XLI (emit_SYMBOL_WITH_POS_SYM (y))))))));
  1591 }
  1592 
  1593 static gcc_jit_rvalue *
  1594 emit_FLOATP (gcc_jit_rvalue *obj)
  1595 {
  1596   emit_comment ("FLOATP");
  1597 
  1598   return emit_TAGGEDP (obj, Lisp_Float);
  1599 }
  1600 
  1601 static gcc_jit_rvalue *
  1602 emit_BIGNUMP (gcc_jit_rvalue *obj)
  1603 {
  1604   /* PSEUDOVECTORP (x, PVEC_BIGNUM); */
  1605   emit_comment ("BIGNUMP");
  1606 
  1607   gcc_jit_rvalue *args[] =
  1608     { obj,
  1609       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  1610                                            comp.int_type,
  1611                                            PVEC_BIGNUM) };
  1612 
  1613   return gcc_jit_context_new_call (comp.ctxt,
  1614                                    NULL,
  1615                                    comp.pseudovectorp,
  1616                                    2,
  1617                                    args);
  1618 }
  1619 
  1620 static gcc_jit_rvalue *
  1621 emit_FIXNUMP (gcc_jit_rvalue *obj)
  1622 {
  1623   /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS))
  1624         - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG))
  1625         & ((1 << INTTYPEBITS) - 1)))  */
  1626   emit_comment ("FIXNUMP");
  1627 
  1628   gcc_jit_rvalue *sh_res =
  1629     USE_LSB_TAG ? obj
  1630     : emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
  1631                       comp.emacs_int_type,
  1632                       emit_XLI (obj),
  1633                       gcc_jit_context_new_rvalue_from_int (
  1634                         comp.ctxt,
  1635                         comp.emacs_int_type,
  1636                         FIXNUM_BITS));
  1637 
  1638   gcc_jit_rvalue *minus_res =
  1639     emit_binary_op (
  1640       GCC_JIT_BINARY_OP_MINUS,
  1641            comp.unsigned_type,
  1642            sh_res,
  1643            gcc_jit_context_new_rvalue_from_int (
  1644              comp.ctxt,
  1645              comp.unsigned_type,
  1646              (Lisp_Int0 >> !USE_LSB_TAG)));
  1647 
  1648   gcc_jit_rvalue *res =
  1649    gcc_jit_context_new_unary_op (
  1650      comp.ctxt,
  1651      NULL,
  1652      GCC_JIT_UNARY_OP_LOGICAL_NEGATE,
  1653      comp.int_type,
  1654      emit_binary_op (
  1655        GCC_JIT_BINARY_OP_BITWISE_AND,
  1656        comp.unsigned_type,
  1657        minus_res,
  1658        gcc_jit_context_new_rvalue_from_int (
  1659          comp.ctxt,
  1660          comp.unsigned_type,
  1661          ((1 << INTTYPEBITS) - 1))));
  1662 
  1663   return res;
  1664 }
  1665 
  1666 static gcc_jit_rvalue *
  1667 emit_XFIXNUM (gcc_jit_rvalue *obj)
  1668 {
  1669   emit_comment ("XFIXNUM");
  1670   gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj));
  1671 
  1672   /* FIXME: Implementation dependent (both RSHIFT are arithmetic).  */
  1673 
  1674   if (!USE_LSB_TAG)
  1675     {
  1676       i = emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
  1677                           comp.emacs_uint_type,
  1678                           i,
  1679                           comp.inttypebits);
  1680 
  1681       return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
  1682                              comp.emacs_int_type,
  1683                              i,
  1684                              comp.inttypebits);
  1685     }
  1686   else
  1687     return emit_coerce (comp.emacs_int_type,
  1688                         emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
  1689                                         comp.emacs_int_type,
  1690                                         i,
  1691                                         comp.inttypebits));
  1692 }
  1693 
  1694 static gcc_jit_rvalue *
  1695 emit_INTEGERP (gcc_jit_rvalue *obj)
  1696 {
  1697   emit_comment ("INTEGERP");
  1698 
  1699   return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
  1700                          comp.bool_type,
  1701                          emit_FIXNUMP (obj),
  1702                          emit_BIGNUMP (obj));
  1703 }
  1704 
  1705 static gcc_jit_rvalue *
  1706 emit_NUMBERP (gcc_jit_rvalue *obj)
  1707 {
  1708   emit_comment ("NUMBERP");
  1709 
  1710   return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
  1711                          comp.bool_type,
  1712                          emit_INTEGERP (obj),
  1713                          emit_FLOATP (obj));
  1714 }
  1715 
  1716 static gcc_jit_rvalue *
  1717 emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n)
  1718 {
  1719   /*
  1720     EMACS_UINT u = n;
  1721     n = u << INTTYPEBITS;
  1722     n += int0;
  1723   */
  1724 
  1725   gcc_jit_rvalue *tmp =
  1726     emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
  1727                     comp.emacs_int_type,
  1728                     n, comp.inttypebits);
  1729 
  1730   tmp = emit_binary_op (GCC_JIT_BINARY_OP_PLUS,
  1731                         comp.emacs_int_type,
  1732                         tmp, comp.lisp_int0);
  1733 
  1734   return emit_coerce (comp.lisp_obj_type, tmp);
  1735 }
  1736 
  1737 static gcc_jit_rvalue *
  1738 emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n)
  1739 {
  1740   /*
  1741     n &= INTMASK;
  1742     n += (int0 << VALBITS);
  1743     return XIL (n);
  1744   */
  1745 
  1746   gcc_jit_rvalue *intmask = emit_rvalue_from_emacs_uint (INTMASK);
  1747 
  1748   n = emit_binary_op (GCC_JIT_BINARY_OP_BITWISE_AND,
  1749                       comp.emacs_uint_type,
  1750                       intmask, n);
  1751 
  1752   n =
  1753     emit_binary_op (GCC_JIT_BINARY_OP_PLUS,
  1754                     comp.emacs_uint_type,
  1755                     emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
  1756                                     comp.emacs_uint_type,
  1757                                     comp.lisp_int0,
  1758                                     emit_rvalue_from_emacs_uint (VALBITS)),
  1759                     n);
  1760 
  1761   return emit_coerce (comp.lisp_obj_type, n);
  1762 }
  1763 
  1764 
  1765 static gcc_jit_rvalue *
  1766 emit_make_fixnum (gcc_jit_rvalue *obj)
  1767 {
  1768   emit_comment ("make_fixnum");
  1769   return USE_LSB_TAG
  1770     ? emit_make_fixnum_LSB_TAG (obj)
  1771     : emit_make_fixnum_MSB_TAG (obj);
  1772 }
  1773 
  1774 static gcc_jit_lvalue *
  1775 emit_lisp_obj_reloc_lval (Lisp_Object obj)
  1776 {
  1777   emit_comment (format_string ("l-value for lisp obj: %s",
  1778                                SSDATA (Fprin1_to_string (obj, Qnil, Qnil))));
  1779 
  1780   imm_reloc_t reloc = obj_to_reloc (obj);
  1781   return gcc_jit_context_new_array_access (comp.ctxt,
  1782                                            NULL,
  1783                                            reloc.array.r_val,
  1784                                            reloc.idx);
  1785 }
  1786 
  1787 static gcc_jit_rvalue *
  1788 emit_lisp_obj_rval (Lisp_Object obj)
  1789 {
  1790   emit_comment (format_string ("const lisp obj: %s",
  1791                                SSDATA (Fprin1_to_string (obj, Qnil, Qnil))));
  1792 
  1793   if (NILP (obj))
  1794     {
  1795       gcc_jit_rvalue *n;
  1796       n = emit_rvalue_from_lisp_word ((Lisp_Word) iQnil);
  1797       return emit_coerce (comp.lisp_obj_type, n);
  1798     }
  1799 
  1800   return gcc_jit_lvalue_as_rvalue (emit_lisp_obj_reloc_lval (obj));
  1801 }
  1802 
  1803 static gcc_jit_rvalue *
  1804 emit_NILP (gcc_jit_rvalue *x)
  1805 {
  1806   emit_comment ("NILP");
  1807   return emit_BASE_EQ (x, emit_lisp_obj_rval (Qnil));
  1808 }
  1809 
  1810 static gcc_jit_rvalue *
  1811 emit_XCAR (gcc_jit_rvalue *c)
  1812 {
  1813   emit_comment ("XCAR");
  1814 
  1815   /* XCONS (c)->u.s.car */
  1816   return
  1817     gcc_jit_rvalue_access_field (
  1818       /* XCONS (c)->u.s */
  1819       gcc_jit_rvalue_access_field (
  1820         /* XCONS (c)->u */
  1821         gcc_jit_lvalue_as_rvalue (
  1822           gcc_jit_rvalue_dereference_field (
  1823             emit_XCONS (c),
  1824             NULL,
  1825             comp.lisp_cons_u)),
  1826         NULL,
  1827         comp.lisp_cons_u_s),
  1828       NULL,
  1829       comp.lisp_cons_u_s_car);
  1830 }
  1831 
  1832 static gcc_jit_lvalue *
  1833 emit_lval_XCAR (gcc_jit_rvalue *c)
  1834 {
  1835   emit_comment ("lval_XCAR");
  1836 
  1837   /* XCONS (c)->u.s.car */
  1838   return
  1839     gcc_jit_lvalue_access_field (
  1840       /* XCONS (c)->u.s */
  1841       gcc_jit_lvalue_access_field (
  1842         /* XCONS (c)->u */
  1843         gcc_jit_rvalue_dereference_field (
  1844           emit_XCONS (c),
  1845           NULL,
  1846           comp.lisp_cons_u),
  1847         NULL,
  1848         comp.lisp_cons_u_s),
  1849       NULL,
  1850       comp.lisp_cons_u_s_car);
  1851 }
  1852 
  1853 static gcc_jit_rvalue *
  1854 emit_XCDR (gcc_jit_rvalue *c)
  1855 {
  1856   emit_comment ("XCDR");
  1857   /* XCONS (c)->u.s.u.cdr */
  1858   return
  1859     gcc_jit_rvalue_access_field (
  1860       /* XCONS (c)->u.s.u */
  1861       gcc_jit_rvalue_access_field (
  1862         /* XCONS (c)->u.s */
  1863         gcc_jit_rvalue_access_field (
  1864           /* XCONS (c)->u */
  1865           gcc_jit_lvalue_as_rvalue (
  1866             gcc_jit_rvalue_dereference_field (
  1867               emit_XCONS (c),
  1868               NULL,
  1869               comp.lisp_cons_u)),
  1870           NULL,
  1871           comp.lisp_cons_u_s),
  1872         NULL,
  1873         comp.lisp_cons_u_s_u),
  1874       NULL,
  1875       comp.lisp_cons_u_s_u_cdr);
  1876 }
  1877 
  1878 static gcc_jit_lvalue *
  1879 emit_lval_XCDR (gcc_jit_rvalue *c)
  1880 {
  1881   emit_comment ("lval_XCDR");
  1882 
  1883   /* XCONS (c)->u.s.u.cdr */
  1884   return
  1885     gcc_jit_lvalue_access_field (
  1886       /* XCONS (c)->u.s.u */
  1887       gcc_jit_lvalue_access_field (
  1888         /* XCONS (c)->u.s */
  1889         gcc_jit_lvalue_access_field (
  1890           /* XCONS (c)->u */
  1891           gcc_jit_rvalue_dereference_field (
  1892             emit_XCONS (c),
  1893             NULL,
  1894             comp.lisp_cons_u),
  1895           NULL,
  1896           comp.lisp_cons_u_s),
  1897         NULL,
  1898         comp.lisp_cons_u_s_u),
  1899       NULL,
  1900       comp.lisp_cons_u_s_u_cdr);
  1901 }
  1902 
  1903 static void
  1904 emit_CHECK_CONS (gcc_jit_rvalue *x)
  1905 {
  1906   emit_comment ("CHECK_CONS");
  1907 
  1908   gcc_jit_rvalue *args[] =
  1909     { emit_CONSP (x),
  1910       emit_lisp_obj_rval (Qconsp),
  1911       x };
  1912 
  1913   gcc_jit_block_add_eval (
  1914     comp.block,
  1915     NULL,
  1916     gcc_jit_context_new_call (comp.ctxt,
  1917                               NULL,
  1918                               comp.check_type,
  1919                               3,
  1920                               args));
  1921 }
  1922 
  1923 static void
  1924 emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x)
  1925 {
  1926   emit_comment ("CHECK_SYMBOL_WITH_POS");
  1927 
  1928   gcc_jit_rvalue *args[] =
  1929     { gcc_jit_context_new_cast (comp.ctxt,
  1930                                 NULL,
  1931                                 emit_SYMBOL_WITH_POS_P (x),
  1932                                 comp.int_type),
  1933       emit_lisp_obj_rval (Qsymbol_with_pos_p),
  1934       x };
  1935 
  1936   gcc_jit_block_add_eval (
  1937     comp.block,
  1938     NULL,
  1939     gcc_jit_context_new_call (comp.ctxt,
  1940                               NULL,
  1941                               comp.check_type,
  1942                               3,
  1943                               args));
  1944 }
  1945 
  1946 static gcc_jit_rvalue *
  1947 emit_car_addr (gcc_jit_rvalue *c)
  1948 {
  1949   emit_comment ("car_addr");
  1950 
  1951   return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL);
  1952 }
  1953 
  1954 static gcc_jit_rvalue *
  1955 emit_cdr_addr (gcc_jit_rvalue *c)
  1956 {
  1957   emit_comment ("cdr_addr");
  1958 
  1959   return gcc_jit_lvalue_get_address (emit_lval_XCDR (c), NULL);
  1960 }
  1961 
  1962 static void
  1963 emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n)
  1964 {
  1965   emit_comment ("XSETCAR");
  1966 
  1967   gcc_jit_block_add_assignment (
  1968     comp.block,
  1969     NULL,
  1970     gcc_jit_rvalue_dereference (
  1971       emit_car_addr (c),
  1972       NULL),
  1973     n);
  1974 }
  1975 
  1976 static void
  1977 emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n)
  1978 {
  1979   emit_comment ("XSETCDR");
  1980 
  1981   gcc_jit_block_add_assignment (
  1982     comp.block,
  1983     NULL,
  1984     gcc_jit_rvalue_dereference (
  1985       emit_cdr_addr (c),
  1986       NULL),
  1987     n);
  1988 }
  1989 
  1990 static gcc_jit_rvalue *
  1991 emit_PURE_P (gcc_jit_rvalue *ptr)
  1992 {
  1993 
  1994   emit_comment ("PURE_P");
  1995 
  1996   return
  1997     gcc_jit_context_new_comparison (
  1998       comp.ctxt,
  1999       NULL,
  2000       GCC_JIT_COMPARISON_LE,
  2001       emit_binary_op (
  2002         GCC_JIT_BINARY_OP_MINUS,
  2003         comp.uintptr_type,
  2004         ptr,
  2005         comp.pure_ptr),
  2006       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2007                                            comp.uintptr_type,
  2008                                            PURESIZE));
  2009 }
  2010 
  2011 
  2012 /*************************************/
  2013 /* Code emitted by LIMPLE statemes.  */
  2014 /*************************************/
  2015 
  2016 /* Emit an r-value from an mvar meta variable.
  2017    In case this is a constant that was propagated return it otherwise load it
  2018    from frame.  */
  2019 
  2020 static gcc_jit_rvalue *
  2021 emit_mvar_rval (Lisp_Object mvar)
  2022 {
  2023   Lisp_Object const_vld = CALL1I (comp-cstr-imm-vld-p, mvar);
  2024 
  2025   if (!NILP (const_vld))
  2026     {
  2027       Lisp_Object value = CALL1I (comp-cstr-imm, mvar);
  2028       if (comp.debug > 1)
  2029         {
  2030           Lisp_Object func =
  2031             Fgethash (value,
  2032                       CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt),
  2033                       Qnil);
  2034 
  2035           emit_comment (
  2036             SSDATA (
  2037               Fprin1_to_string (
  2038                 NILP (func) ? value : CALL1I (comp-func-c-name, func),
  2039                 Qnil, Qnil)));
  2040         }
  2041       if (FIXNUMP (value))
  2042         {
  2043           /* We can still emit directly objects that are self-contained in a
  2044              word (read fixnums).  */
  2045           return emit_rvalue_from_lisp_obj (value);
  2046         }
  2047       /* Other const objects are fetched from the reloc array.  */
  2048       return emit_lisp_obj_rval (value);
  2049     }
  2050 
  2051   return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar));
  2052 }
  2053 
  2054 static void
  2055 emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val)
  2056 {
  2057 
  2058   gcc_jit_block_add_assignment (
  2059     comp.block,
  2060     NULL,
  2061     emit_mvar_lval (dst_mvar),
  2062     val);
  2063 }
  2064 
  2065 static gcc_jit_rvalue *
  2066 emit_set_internal (Lisp_Object args)
  2067 {
  2068   /*
  2069     Ex: (set_internal #s(comp-mvar nil nil t comp-test-up-val nil nil)
  2070                       #s(comp-mvar 1 4 t nil symbol nil)).
  2071   */
  2072   /* TODO: Inline the most common case.  */
  2073   if (list_length (args) != 3)
  2074     xsignal2 (Qnative_ice,
  2075               build_string ("unexpected arg length for insns"),
  2076               args);
  2077 
  2078   args = XCDR (args);
  2079   int i = 0;
  2080   gcc_jit_rvalue *gcc_args[4];
  2081   FOR_EACH_TAIL (args)
  2082     gcc_args[i++] = emit_mvar_rval (XCAR (args));
  2083   gcc_args[2] = emit_lisp_obj_rval (Qnil);
  2084   gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2085                                                      comp.int_type,
  2086                                                      SET_INTERNAL_SET);
  2087   return emit_call (intern_c_string ("set_internal"), comp.void_type , 4,
  2088                     gcc_args, false);
  2089 }
  2090 
  2091 /* This is for a regular function with arguments as m-var.  */
  2092 
  2093 static gcc_jit_rvalue *
  2094 emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct)
  2095 {
  2096   USE_SAFE_ALLOCA;
  2097   int i = 0;
  2098   Lisp_Object callee = FIRST (args);
  2099   args = XCDR (args);
  2100   ptrdiff_t nargs = list_length (args);
  2101   gcc_jit_rvalue **gcc_args = SAFE_ALLOCA (nargs * sizeof (*gcc_args));
  2102   FOR_EACH_TAIL (args)
  2103     gcc_args[i++] = emit_mvar_rval (XCAR (args));
  2104 
  2105   SAFE_FREE ();
  2106   return emit_call (callee, ret_type, nargs, gcc_args, direct);
  2107 }
  2108 
  2109 static gcc_jit_rvalue *
  2110 emit_simple_limple_call_lisp_ret (Lisp_Object args)
  2111 {
  2112   /*
  2113     Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil)).
  2114   */
  2115   return emit_simple_limple_call (args, comp.lisp_obj_type, false);
  2116 }
  2117 
  2118 static gcc_jit_rvalue *
  2119 emit_simple_limple_call_void_ret (Lisp_Object args)
  2120 {
  2121   return emit_simple_limple_call (args, comp.void_type, false);
  2122 }
  2123 
  2124 /* Entry point to dispatch emitting (call fun ...).  */
  2125 
  2126 static gcc_jit_rvalue *
  2127 emit_limple_call (Lisp_Object insn)
  2128 {
  2129   Lisp_Object callee_sym = FIRST (insn);
  2130   Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil);
  2131 
  2132   if (!NILP (emitter))
  2133     {
  2134       gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter);
  2135       return emitter_ptr (insn);
  2136     }
  2137 
  2138   return emit_simple_limple_call_lisp_ret (insn);
  2139 }
  2140 
  2141 static gcc_jit_rvalue *
  2142 emit_limple_call_ref (Lisp_Object insn, bool direct)
  2143 {
  2144   /* Ex: (funcall #s(comp-mvar 1 5 t eql symbol t)
  2145                   #s(comp-mvar 2 6 nil nil nil t)
  2146                   #s(comp-mvar 3 7 t 0 fixnum t)).  */
  2147   static int i = 0;
  2148   Lisp_Object callee = FIRST (insn);
  2149   EMACS_INT nargs = XFIXNUM (Flength (CDR (insn)));
  2150 
  2151   if (!nargs)
  2152     return emit_call_ref (callee, 0, comp.frame[0], direct);
  2153 
  2154   if (comp.func_has_non_local || !comp.func_speed)
  2155     {
  2156       /* FIXME: See bug#42360.  */
  2157       Lisp_Object first_arg = SECOND (insn);
  2158       EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg));
  2159       return emit_call_ref (callee, nargs, comp.frame[first_slot], direct);
  2160     }
  2161 
  2162   gcc_jit_lvalue *tmp_arr =
  2163     gcc_jit_function_new_local (
  2164       comp.func,
  2165       NULL,
  2166       gcc_jit_context_new_array_type (comp.ctxt,
  2167                                       NULL,
  2168                                       comp.lisp_obj_type,
  2169                                       nargs),
  2170       format_string ("call_arr_%d", i++));
  2171 
  2172   ptrdiff_t j = 0;
  2173   Lisp_Object arg = CDR (insn);
  2174   FOR_EACH_TAIL (arg)
  2175     {
  2176       gcc_jit_block_add_assignment (
  2177         comp.block,
  2178         NULL,
  2179         gcc_jit_context_new_array_access (
  2180           comp.ctxt,
  2181           NULL,
  2182           gcc_jit_lvalue_as_rvalue (tmp_arr),
  2183           gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2184                                                comp.int_type,
  2185                                                j)),
  2186         emit_mvar_rval (XCAR (arg)));
  2187       ++j;
  2188     }
  2189 
  2190   return emit_call_ref (
  2191            callee,
  2192            nargs,
  2193            gcc_jit_context_new_array_access (comp.ctxt,
  2194                                              NULL,
  2195                                              gcc_jit_lvalue_as_rvalue (tmp_arr),
  2196                                              comp.zero),
  2197            direct);
  2198 }
  2199 
  2200 static gcc_jit_rvalue *
  2201 emit_setjmp (gcc_jit_rvalue *buf)
  2202 {
  2203 #ifndef WINDOWSNT
  2204   gcc_jit_rvalue *args[] = {buf};
  2205   gcc_jit_param *params[] =
  2206   {
  2207     gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"),
  2208   };
  2209   /* Don't call setjmp through a function pointer (Bug#46824) */
  2210   gcc_jit_function *f =
  2211     gcc_jit_context_new_function (comp.ctxt, NULL,
  2212                                   GCC_JIT_FUNCTION_IMPORTED,
  2213                                   comp.int_type, STR (SETJMP_NAME),
  2214                                   ARRAYELTS (params), params,
  2215                                   false);
  2216 
  2217   return gcc_jit_context_new_call (comp.ctxt, NULL, f, 1, args);
  2218 #else
  2219   /* _setjmp (buf, __builtin_frame_address (0)) */
  2220   gcc_jit_param *params[] =
  2221   {
  2222     gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"),
  2223     gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "frame"),
  2224   };
  2225   gcc_jit_rvalue *args[2];
  2226 
  2227   args[0] =
  2228     gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0);
  2229 
  2230   args[1] =
  2231     gcc_jit_context_new_call (
  2232       comp.ctxt,
  2233       NULL,
  2234       gcc_jit_context_get_builtin_function (comp.ctxt,
  2235                                             "__builtin_frame_address"),
  2236       1, args);
  2237   args[0] = buf;
  2238   gcc_jit_function *f =
  2239     gcc_jit_context_new_function (comp.ctxt, NULL,
  2240                                   GCC_JIT_FUNCTION_IMPORTED,
  2241                                   comp.int_type, STR (SETJMP_NAME),
  2242                                   ARRAYELTS (params), params,
  2243                                   false);
  2244 
  2245   return gcc_jit_context_new_call (comp.ctxt, NULL, f, 2, args);
  2246 #endif
  2247 }
  2248 
  2249 /* Register an handler for a non local exit.  */
  2250 
  2251 static void
  2252 emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type,
  2253                           gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb,
  2254                           Lisp_Object clobbered_mvar)
  2255 {
  2256    /* struct handler *c = push_handler (POP, type);  */
  2257 
  2258   gcc_jit_rvalue *args[] = { handler, handler_type };
  2259   gcc_jit_block_add_assignment (
  2260     comp.block,
  2261     NULL,
  2262     comp.loc_handler,
  2263     emit_call (intern_c_string ("push_handler"),
  2264                comp.handler_ptr_type, 2, args, false));
  2265 
  2266   args[0] =
  2267     gcc_jit_lvalue_get_address (
  2268         gcc_jit_rvalue_dereference_field (
  2269           gcc_jit_lvalue_as_rvalue (comp.loc_handler),
  2270           NULL,
  2271           comp.handler_jmp_field),
  2272         NULL);
  2273 
  2274   gcc_jit_rvalue *res;
  2275   res = emit_setjmp (args[0]);
  2276   emit_cond_jump (res, handler_bb, guarded_bb);
  2277 }
  2278 
  2279 static void
  2280 emit_limple_insn (Lisp_Object insn)
  2281 {
  2282   Lisp_Object op = XCAR (insn);
  2283   Lisp_Object args = XCDR (insn);
  2284   gcc_jit_rvalue *res;
  2285   Lisp_Object arg[6];
  2286 
  2287   Lisp_Object p = XCDR (insn);
  2288   ptrdiff_t i = 0;
  2289   FOR_EACH_TAIL (p)
  2290     {
  2291       if (i == sizeof (arg) / sizeof (Lisp_Object))
  2292         break;
  2293       arg[i++] = XCAR (p);
  2294     }
  2295 
  2296   if (EQ (op, Qjump))
  2297     {
  2298       /* Unconditional branch.  */
  2299       gcc_jit_block *target = retrive_block (arg[0]);
  2300       gcc_jit_block_end_with_jump (comp.block, NULL, target);
  2301     }
  2302   else if (EQ (op, Qcond_jump))
  2303     {
  2304       /* Conditional branch.  */
  2305       gcc_jit_rvalue *a = emit_mvar_rval (arg[0]);
  2306       gcc_jit_rvalue *b = emit_mvar_rval (arg[1]);
  2307       gcc_jit_block *target1 = retrive_block (arg[2]);
  2308       gcc_jit_block *target2 = retrive_block (arg[3]);
  2309 
  2310       if ((!NILP (CALL1I (comp-cstr-imm-vld-p, arg[0]))
  2311            && NILP (CALL1I (comp-cstr-imm, arg[0])))
  2312           || (!NILP (CALL1I (comp-cstr-imm-vld-p, arg[1]))
  2313               && NILP (CALL1I (comp-cstr-imm, arg[1]))))
  2314         emit_cond_jump (emit_BASE_EQ (a, b), target1, target2);
  2315       else
  2316         emit_cond_jump (emit_EQ (a, b), target1, target2);
  2317     }
  2318   else if (EQ (op, Qcond_jump_narg_leq))
  2319     {
  2320       /*
  2321          Limple: (cond-jump-narg-less 2 entry_2 entry_fallback_2)
  2322          C: if (nargs < 2) goto entry2_fallback; else goto entry_2;
  2323       */
  2324       gcc_jit_lvalue *nargs =
  2325         gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0));
  2326       eassert (XFIXNUM (arg[0]) < INT_MAX);
  2327       gcc_jit_rvalue *n =
  2328         gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2329                                              comp.ptrdiff_type,
  2330                                              XFIXNUM (arg[0]));
  2331       gcc_jit_block *target1 = retrive_block (arg[1]);
  2332       gcc_jit_block *target2 = retrive_block (arg[2]);
  2333       gcc_jit_rvalue *test = gcc_jit_context_new_comparison (
  2334                                comp.ctxt,
  2335                                NULL,
  2336                                GCC_JIT_COMPARISON_LE,
  2337                                gcc_jit_lvalue_as_rvalue (nargs),
  2338                                n);
  2339       emit_cond_jump (test, target1, target2);
  2340     }
  2341   else if (EQ (op, Qphi) || EQ (op, Qassume))
  2342     {
  2343       /* Nothing to do for phis or assumes in the backend.  */
  2344     }
  2345   else if (EQ (op, Qpush_handler))
  2346     {
  2347       /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */
  2348       int h_num UNINIT;
  2349       Lisp_Object handler_spec = arg[0];
  2350       gcc_jit_rvalue *handler = emit_mvar_rval (arg[1]);
  2351       if (EQ (handler_spec, Qcatcher))
  2352         h_num = CATCHER;
  2353       else if (EQ (handler_spec, Qcondition_case))
  2354         h_num = CONDITION_CASE;
  2355       else
  2356         xsignal2 (Qnative_ice, build_string ("incoherent insn"), insn);
  2357       gcc_jit_rvalue *handler_type =
  2358         gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2359                                              comp.int_type,
  2360                                              h_num);
  2361       gcc_jit_block *handler_bb = retrive_block (arg[2]);
  2362       gcc_jit_block *guarded_bb = retrive_block (arg[3]);
  2363       emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb,
  2364                                 arg[0]);
  2365     }
  2366   else if (EQ (op, Qpop_handler))
  2367     {
  2368       /*
  2369         C: current_thread->m_handlerlist =
  2370              current_thread->m_handlerlist->next;
  2371       */
  2372       gcc_jit_lvalue *m_handlerlist =
  2373         gcc_jit_rvalue_dereference_field (
  2374           gcc_jit_lvalue_as_rvalue (
  2375             gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)),
  2376           NULL,
  2377           comp.m_handlerlist);
  2378 
  2379       gcc_jit_block_add_assignment (
  2380         comp.block,
  2381         NULL,
  2382         m_handlerlist,
  2383         gcc_jit_lvalue_as_rvalue (
  2384           gcc_jit_rvalue_dereference_field (
  2385             gcc_jit_lvalue_as_rvalue (m_handlerlist),
  2386             NULL,
  2387             comp.handler_next_field)));
  2388 
  2389     }
  2390   else if (EQ (op, Qfetch_handler))
  2391     {
  2392       gcc_jit_lvalue *m_handlerlist =
  2393         gcc_jit_rvalue_dereference_field (
  2394           gcc_jit_lvalue_as_rvalue (
  2395             gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)),
  2396           NULL,
  2397           comp.m_handlerlist);
  2398       gcc_jit_block_add_assignment (comp.block,
  2399                                     NULL,
  2400                                     comp.loc_handler,
  2401                                     gcc_jit_lvalue_as_rvalue (m_handlerlist));
  2402 
  2403       gcc_jit_block_add_assignment (
  2404         comp.block,
  2405         NULL,
  2406         m_handlerlist,
  2407         gcc_jit_lvalue_as_rvalue (
  2408           gcc_jit_rvalue_dereference_field (
  2409             gcc_jit_lvalue_as_rvalue (comp.loc_handler),
  2410             NULL,
  2411             comp.handler_next_field)));
  2412       emit_frame_assignment (
  2413         arg[0],
  2414         gcc_jit_lvalue_as_rvalue (
  2415           gcc_jit_rvalue_dereference_field (
  2416             gcc_jit_lvalue_as_rvalue (comp.loc_handler),
  2417             NULL,
  2418             comp.handler_val_field)));
  2419     }
  2420   else if (EQ (op, Qcall))
  2421     {
  2422       gcc_jit_block_add_eval (comp.block, NULL,
  2423                               emit_limple_call (args));
  2424     }
  2425   else if (EQ (op, Qcallref))
  2426     {
  2427       gcc_jit_block_add_eval (comp.block, NULL,
  2428                               emit_limple_call_ref (args, false));
  2429     }
  2430   else if (EQ (op, Qdirect_call))
  2431     {
  2432       gcc_jit_block_add_eval (
  2433         comp.block, NULL,
  2434         emit_simple_limple_call (XCDR (insn), comp.lisp_obj_type, true));
  2435     }
  2436   else if (EQ (op, Qdirect_callref))
  2437     {
  2438       gcc_jit_block_add_eval (comp.block, NULL,
  2439                               emit_limple_call_ref (XCDR (insn), true));
  2440     }
  2441   else if (EQ (op, Qset))
  2442     {
  2443       Lisp_Object arg1 = arg[1];
  2444 
  2445       if (EQ (Ftype_of (arg1), Qcomp_mvar))
  2446         res = emit_mvar_rval (arg1);
  2447       else if (EQ (FIRST (arg1), Qcall))
  2448         res = emit_limple_call (XCDR (arg1));
  2449       else if (EQ (FIRST (arg1), Qcallref))
  2450         res = emit_limple_call_ref (XCDR (arg1), false);
  2451       else if (EQ (FIRST (arg1), Qdirect_call))
  2452         res = emit_simple_limple_call (XCDR (arg1), comp.lisp_obj_type, true);
  2453       else if (EQ (FIRST (arg1), Qdirect_callref))
  2454         res = emit_limple_call_ref (XCDR (arg1), true);
  2455       else
  2456         xsignal2 (Qnative_ice,
  2457                   build_string ("LIMPLE inconsistent arg1 for insn"),
  2458                   insn);
  2459 
  2460       if (!res)
  2461         xsignal1 (Qnative_ice,
  2462                   build_string (gcc_jit_context_get_first_error (comp.ctxt)));
  2463 
  2464       emit_frame_assignment (arg[0], res);
  2465     }
  2466   else if (EQ (op, Qset_par_to_local))
  2467     {
  2468       /* Ex: (set-par-to-local #s(comp-mvar 0 3 nil nil nil nil) 0).  */
  2469       EMACS_INT param_n = XFIXNUM (arg[1]);
  2470       eassert (param_n < INT_MAX);
  2471       gcc_jit_rvalue *param =
  2472         gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func,
  2473                                                              param_n));
  2474       emit_frame_assignment (arg[0], param);
  2475     }
  2476   else if (EQ (op, Qset_args_to_local))
  2477     {
  2478       /*
  2479         Ex: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil))
  2480         C: local[1] = *args;
  2481       */
  2482       gcc_jit_rvalue *gcc_args =
  2483         gcc_jit_lvalue_as_rvalue (
  2484           gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)));
  2485 
  2486       gcc_jit_rvalue *res =
  2487         gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL));
  2488 
  2489       emit_frame_assignment (arg[0], res);
  2490     }
  2491   else if (EQ (op, Qset_rest_args_to_local))
  2492     {
  2493       /*
  2494         Ex: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil))
  2495         C: local[2] = list (nargs - 2, args);
  2496       */
  2497 
  2498       EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, arg[0]));
  2499       eassert (slot_n < INT_MAX);
  2500       gcc_jit_rvalue *n =
  2501         gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2502                                              comp.ptrdiff_type,
  2503                                              slot_n);
  2504       gcc_jit_lvalue *nargs =
  2505         gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0));
  2506       gcc_jit_lvalue *args =
  2507         gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1));
  2508 
  2509       gcc_jit_rvalue *list_args[] =
  2510         { emit_binary_op (GCC_JIT_BINARY_OP_MINUS,
  2511                           comp.ptrdiff_type,
  2512                           gcc_jit_lvalue_as_rvalue (nargs),
  2513                           n),
  2514           gcc_jit_lvalue_as_rvalue (args) };
  2515 
  2516       res = emit_call (Qlist, comp.lisp_obj_type, 2,
  2517                        list_args, false);
  2518 
  2519       emit_frame_assignment (arg[0], res);
  2520     }
  2521   else if (EQ (op, Qinc_args))
  2522     {
  2523       /*
  2524         Ex: (inc-args)
  2525         C: ++args;
  2526       */
  2527       gcc_jit_lvalue *args =
  2528         gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1));
  2529 
  2530       gcc_jit_block_add_assignment (comp.block,
  2531                                     NULL,
  2532                                     args,
  2533                                     emit_ptr_arithmetic (
  2534                                       gcc_jit_lvalue_as_rvalue (args),
  2535                                       comp.lisp_obj_ptr_type,
  2536                                       sizeof (Lisp_Object),
  2537                                       comp.one));
  2538     }
  2539   else if (EQ (op, Qsetimm))
  2540     {
  2541       /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) a).  */
  2542       emit_comment (SSDATA (Fprin1_to_string (arg[1], Qnil, Qnil)));
  2543       imm_reloc_t reloc = obj_to_reloc (arg[1]);
  2544       emit_frame_assignment (
  2545         arg[0],
  2546         gcc_jit_lvalue_as_rvalue (
  2547           gcc_jit_context_new_array_access (comp.ctxt,
  2548                                             NULL,
  2549                                             reloc.array.r_val,
  2550                                             reloc.idx)));
  2551     }
  2552   else if (EQ (op, Qcomment))
  2553     {
  2554       /* Ex: (comment "Function: foo").  */
  2555       emit_comment (SSDATA (arg[0]));
  2556     }
  2557   else if (EQ (op, Qreturn))
  2558     {
  2559       gcc_jit_block_end_with_return (comp.block,
  2560                                      NULL,
  2561                                      emit_mvar_rval (arg[0]));
  2562     }
  2563   else if (EQ (op, Qunreachable))
  2564     {
  2565       /* Libgccjit has no __builtin_unreachable.  */
  2566       gcc_jit_block_end_with_return (comp.block,
  2567                                      NULL,
  2568                                      emit_lisp_obj_rval (Qnil));
  2569     }
  2570   else
  2571     {
  2572       xsignal2 (Qnative_ice,
  2573                 build_string ("LIMPLE op inconsistent"),
  2574                 op);
  2575     }
  2576 }
  2577 
  2578 
  2579 /**************/
  2580 /* Inliners.  */
  2581 /**************/
  2582 
  2583 static gcc_jit_rvalue *
  2584 emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
  2585                           Lisp_Object type)
  2586 {
  2587   bool hint_match =
  2588     !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
  2589   gcc_jit_rvalue *args[] =
  2590     { emit_mvar_rval (SECOND (insn)),
  2591       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2592                                            comp.bool_type,
  2593                                            hint_match) };
  2594 
  2595   return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args);
  2596 }
  2597 
  2598 /* Same as before but with two args. The type hint is on the 2th.  */
  2599 static gcc_jit_rvalue *
  2600 emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
  2601                            Lisp_Object type)
  2602 {
  2603   bool hint_match =
  2604     !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
  2605   gcc_jit_rvalue *args[] =
  2606     { emit_mvar_rval (SECOND (insn)),
  2607       emit_mvar_rval (THIRD (insn)),
  2608       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2609                                            comp.bool_type,
  2610                                            hint_match) };
  2611 
  2612   return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args);
  2613 }
  2614 
  2615 
  2616 static gcc_jit_rvalue *
  2617 emit_add1 (Lisp_Object insn)
  2618 {
  2619   return emit_call_with_type_hint (comp.add1, insn, Qfixnum);
  2620 }
  2621 
  2622 static gcc_jit_rvalue *
  2623 emit_sub1 (Lisp_Object insn)
  2624 {
  2625   return emit_call_with_type_hint (comp.sub1, insn, Qfixnum);
  2626 }
  2627 
  2628 static gcc_jit_rvalue *
  2629 emit_negate (Lisp_Object insn)
  2630 {
  2631   return emit_call_with_type_hint (comp.negate, insn, Qfixnum);
  2632 }
  2633 
  2634 static gcc_jit_rvalue *
  2635 emit_consp (Lisp_Object insn)
  2636 {
  2637   gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn));
  2638   gcc_jit_rvalue *res = emit_coerce (comp.bool_type,
  2639                                    emit_CONSP (x));
  2640   return gcc_jit_context_new_call (comp.ctxt,
  2641                                    NULL,
  2642                                    comp.bool_to_lisp_obj,
  2643                                    1, &res);
  2644 }
  2645 
  2646 static gcc_jit_rvalue *
  2647 emit_car (Lisp_Object insn)
  2648 {
  2649   return emit_call_with_type_hint (comp.car, insn, Qcons);
  2650 }
  2651 
  2652 static gcc_jit_rvalue *
  2653 emit_cdr (Lisp_Object insn)
  2654 {
  2655   return emit_call_with_type_hint (comp.cdr, insn, Qcons);
  2656 }
  2657 
  2658 static gcc_jit_rvalue *
  2659 emit_setcar (Lisp_Object insn)
  2660 {
  2661   return emit_call2_with_type_hint (comp.setcar, insn, Qcons);
  2662 }
  2663 
  2664 static gcc_jit_rvalue *
  2665 emit_setcdr (Lisp_Object insn)
  2666 {
  2667   return emit_call2_with_type_hint (comp.setcdr, insn, Qcons);
  2668 }
  2669 
  2670 static gcc_jit_rvalue *
  2671 emit_numperp (Lisp_Object insn)
  2672 {
  2673   gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn));
  2674   gcc_jit_rvalue *res = emit_NUMBERP (x);
  2675   return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1,
  2676                                    &res);
  2677 }
  2678 
  2679 static gcc_jit_rvalue *
  2680 emit_integerp (Lisp_Object insn)
  2681 {
  2682   gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn));
  2683   gcc_jit_rvalue *res = emit_INTEGERP (x);
  2684   return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1,
  2685                                    &res);
  2686 }
  2687 
  2688 static gcc_jit_rvalue *
  2689 emit_maybe_gc_or_quit (Lisp_Object insn)
  2690 {
  2691   return gcc_jit_context_new_call (comp.ctxt, NULL, comp.maybe_gc_or_quit, 0,
  2692                                    NULL);
  2693 }
  2694 
  2695 /* This is in charge of serializing an object and export a function to
  2696    retrieve it at load time.  */
  2697 #pragma GCC diagnostic push
  2698 #pragma GCC diagnostic ignored "-Waddress"
  2699 static void
  2700 emit_static_object (const char *name, Lisp_Object obj)
  2701 {
  2702   /* libgccjit has no support for initialized static data.
  2703      The mechanism below is certainly not aesthetic but I assume the bottle neck
  2704      in terms of performance at load time will still be the reader.
  2705      NOTE: we can not rely on libgccjit even for valid NULL terminated C
  2706      strings cause of this funny bug that will affect all pre gcc10 era gccs:
  2707      https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html  */
  2708 
  2709   specpdl_ref count = SPECPDL_INDEX ();
  2710   /* Preserve uninterned symbols, this is specifically necessary for
  2711      CL macro expansion in dynamic scope code (bug#42088).  See
  2712      `byte-compile-output-file-form'.  */
  2713   specbind (intern_c_string ("print-escape-newlines"), Qt);
  2714   specbind (intern_c_string ("print-length"), Qnil);
  2715   specbind (intern_c_string ("print-level"), Qnil);
  2716   specbind (intern_c_string ("print-quoted"), Qt);
  2717   specbind (intern_c_string ("print-gensym"), Qt);
  2718   specbind (intern_c_string ("print-circle"), Qt);
  2719   Lisp_Object str = Fprin1_to_string (obj, Qnil, Qnil);
  2720   unbind_to (count, Qnil);
  2721 
  2722   ptrdiff_t len = SBYTES (str);
  2723   const char *p = SSDATA (str);
  2724 
  2725 #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer)
  2726   if (gcc_jit_global_set_initializer)
  2727     {
  2728       ptrdiff_t str_size = len + 1;
  2729       ptrdiff_t size = sizeof (static_obj_t) + str_size;
  2730       static_obj_t *static_obj = xmalloc (size);
  2731       static_obj->len = str_size;
  2732       memcpy (static_obj->data, p, str_size);
  2733       gcc_jit_lvalue *blob =
  2734         gcc_jit_context_new_global (
  2735           comp.ctxt,
  2736           NULL,
  2737           GCC_JIT_GLOBAL_EXPORTED,
  2738           gcc_jit_context_new_array_type (comp.ctxt, NULL,
  2739                                           comp.char_type,
  2740                                           size),
  2741           format_string ("%s_blob", name));
  2742       gcc_jit_global_set_initializer (blob, static_obj, size);
  2743       xfree (static_obj);
  2744 
  2745       return;
  2746     }
  2747 #endif
  2748 
  2749   gcc_jit_type *a_type =
  2750     gcc_jit_context_new_array_type (comp.ctxt,
  2751                                     NULL,
  2752                                     comp.char_type,
  2753                                     len + 1);
  2754   gcc_jit_field *fields[] =
  2755     { gcc_jit_context_new_field (comp.ctxt,
  2756                                  NULL,
  2757                                  comp.ptrdiff_type,
  2758                                  "len"),
  2759       gcc_jit_context_new_field (comp.ctxt,
  2760                                  NULL,
  2761                                  a_type,
  2762                                  "data") };
  2763 
  2764   gcc_jit_type *data_struct_t =
  2765     gcc_jit_struct_as_type (
  2766       gcc_jit_context_new_struct_type (comp.ctxt,
  2767                                        NULL,
  2768                                        format_string ("%s_struct", name),
  2769                                        ARRAYELTS (fields), fields));
  2770 
  2771   gcc_jit_lvalue *data_struct =
  2772     gcc_jit_context_new_global (comp.ctxt,
  2773                                 NULL,
  2774                                 GCC_JIT_GLOBAL_INTERNAL,
  2775                                 data_struct_t,
  2776                                 format_string ("%s_s", name));
  2777 
  2778   gcc_jit_function *f =
  2779     gcc_jit_context_new_function (comp.ctxt, NULL,
  2780                                   GCC_JIT_FUNCTION_EXPORTED,
  2781                                   gcc_jit_type_get_pointer (data_struct_t),
  2782                                   name,
  2783                                   0, NULL, 0);
  2784   DECL_BLOCK (block, f);
  2785 
  2786   if (comp.debug > 1)
  2787     {
  2788       char *comment = memcpy (xmalloc (len), p, len);
  2789       for (ptrdiff_t i = 0; i < len - 1; i++)
  2790         if (!comment[i])
  2791           comment[i] = '\n';
  2792       gcc_jit_block_add_comment (block, NULL, comment);
  2793       xfree (comment);
  2794     }
  2795 
  2796   gcc_jit_lvalue *arr =
  2797       gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]);
  2798 
  2799   gcc_jit_lvalue *ptrvar = gcc_jit_function_new_local (f, NULL,
  2800                                                        comp.char_ptr_type,
  2801                                                        "ptr");
  2802 
  2803   gcc_jit_block_add_assignment (
  2804     block,
  2805     NULL,
  2806     ptrvar,
  2807     gcc_jit_lvalue_get_address (
  2808       gcc_jit_context_new_array_access (
  2809         comp.ctxt,
  2810         NULL,
  2811         gcc_jit_lvalue_as_rvalue (arr),
  2812         gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, 0)),
  2813       NULL));
  2814 
  2815   /* We can't use always string literals longer that 200 bytes because
  2816      they cause a crash in pre GCC 10 libgccjit.
  2817      <https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html>.
  2818 
  2819      Adjust if possible to reduce the number of function calls.  */
  2820   size_t chunck_size = NILP (Fcomp_libgccjit_version ()) ? 200 : 1024;
  2821   char *buff = xmalloc (chunck_size);
  2822   for (ptrdiff_t i = 0; i < len;)
  2823     {
  2824       strncpy (buff, p, chunck_size);
  2825       buff[chunck_size - 1] = 0;
  2826       uintptr_t l = strlen (buff);
  2827 
  2828       if (l != 0)
  2829         {
  2830           p += l;
  2831           i += l;
  2832 
  2833           gcc_jit_rvalue *args[] =
  2834             { gcc_jit_lvalue_as_rvalue (ptrvar),
  2835               gcc_jit_context_new_string_literal (comp.ctxt, buff),
  2836               gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2837                                                    comp.size_t_type,
  2838                                                    l) };
  2839 
  2840           gcc_jit_block_add_eval (block, NULL,
  2841                                   gcc_jit_context_new_call (comp.ctxt, NULL,
  2842                                                             comp.memcpy,
  2843                                                             ARRAYELTS (args),
  2844                                                             args));
  2845           gcc_jit_block_add_assignment (block, NULL, ptrvar,
  2846             gcc_jit_lvalue_get_address (
  2847               gcc_jit_context_new_array_access (comp.ctxt, NULL,
  2848                 gcc_jit_lvalue_as_rvalue (ptrvar),
  2849                 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2850                                                      comp.uintptr_type,
  2851                                                      l)),
  2852               NULL));
  2853         }
  2854       else
  2855         {
  2856           /* If strlen returned 0 that means that the static object
  2857              contains a NULL byte.  In that case just move over to the
  2858              next block.  We can rely on the byte being zero because
  2859              of the previous call to bzero and because the dynamic
  2860              linker cleared it.  */
  2861           p++;
  2862           i++;
  2863           gcc_jit_block_add_assignment (
  2864             block, NULL, ptrvar,
  2865             gcc_jit_lvalue_get_address (
  2866               gcc_jit_context_new_array_access (
  2867                 comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue (ptrvar),
  2868                 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2869                                                      comp.uintptr_type, 1)),
  2870               NULL));
  2871         }
  2872     }
  2873   xfree (buff);
  2874 
  2875   gcc_jit_block_add_assignment (
  2876         block,
  2877         NULL,
  2878         gcc_jit_lvalue_access_field (data_struct, NULL, fields[0]),
  2879         gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  2880                                              comp.ptrdiff_type,
  2881                                              len));
  2882   gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (data_struct, NULL);
  2883   gcc_jit_block_end_with_return (block, NULL, res);
  2884 }
  2885 #pragma GCC diagnostic pop
  2886 
  2887 static reloc_array_t
  2888 declare_imported_data_relocs (Lisp_Object container, const char *code_symbol,
  2889                               const char *text_symbol)
  2890 {
  2891   /* Imported objects.  */
  2892   reloc_array_t res;
  2893   res.len =
  2894     XFIXNUM (CALL1I (hash-table-count,
  2895                      CALL1I (comp-data-container-idx, container)));
  2896   Lisp_Object d_reloc = CALL1I (comp-data-container-l, container);
  2897   d_reloc = Fvconcat (1, &d_reloc);
  2898 
  2899   res.r_val =
  2900     gcc_jit_lvalue_as_rvalue (
  2901       gcc_jit_context_new_global (
  2902         comp.ctxt,
  2903         NULL,
  2904         GCC_JIT_GLOBAL_EXPORTED,
  2905         gcc_jit_context_new_array_type (comp.ctxt,
  2906                                         NULL,
  2907                                         comp.lisp_obj_type,
  2908                                         res.len),
  2909         code_symbol));
  2910 
  2911   emit_static_object (text_symbol, d_reloc);
  2912 
  2913   return res;
  2914 }
  2915 
  2916 static void
  2917 declare_imported_data (void)
  2918 {
  2919   /* Imported objects.  */
  2920   comp.data_relocs =
  2921     declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt),
  2922                                   DATA_RELOC_SYM,
  2923                                   TEXT_DATA_RELOC_SYM);
  2924   comp.data_relocs_impure =
  2925     declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt),
  2926                                   DATA_RELOC_IMPURE_SYM,
  2927                                   TEXT_DATA_RELOC_IMPURE_SYM);
  2928   comp.data_relocs_ephemeral =
  2929     declare_imported_data_relocs (CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt),
  2930                                   DATA_RELOC_EPHEMERAL_SYM,
  2931                                   TEXT_DATA_RELOC_EPHEMERAL_SYM);
  2932 }
  2933 
  2934 /*
  2935   Declare as imported all the functions that are requested from the runtime.
  2936   These are either subrs or not.  Note that the list created here must match
  2937   the array `helper_link_table'.
  2938 */
  2939 static Lisp_Object
  2940 declare_runtime_imported_funcs (void)
  2941 {
  2942   Lisp_Object field_list = Qnil;
  2943 
  2944 #define ADD_IMPORTED(f_name, ret_type, nargs, args)                            \
  2945   do {                                                                         \
  2946     Lisp_Object name = intern_c_string (STR (f_name));                         \
  2947     Lisp_Object field =                                                        \
  2948       make_mint_ptr (declare_imported_func (name, ret_type, nargs, args));     \
  2949     Lisp_Object el = Fcons (name, field);                                      \
  2950     field_list = Fcons (el, field_list);                                       \
  2951   } while (0)
  2952 
  2953   gcc_jit_type *args[4];
  2954 
  2955   ADD_IMPORTED (wrong_type_argument, comp.void_type, 2, NULL);
  2956 
  2957   args[0] = comp.lisp_obj_type;
  2958   args[1] = comp.int_type;
  2959   ADD_IMPORTED (helper_PSEUDOVECTOR_TYPEP_XUNTAG, comp.bool_type, 2, args);
  2960 
  2961   ADD_IMPORTED (pure_write_error, comp.void_type, 1, NULL);
  2962 
  2963   args[0] = comp.lisp_obj_type;
  2964   args[1] = comp.int_type;
  2965   ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args);
  2966 
  2967   ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL);
  2968 
  2969   args[0] = comp.lisp_obj_type;
  2970   ADD_IMPORTED (helper_unbind_n, comp.lisp_obj_type, 1, args);
  2971 
  2972   ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL);
  2973 
  2974   args[0] = comp.lisp_obj_type;
  2975   ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type,
  2976                 1, args);
  2977 
  2978   ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL);
  2979 
  2980   args[0] = args[1] = args[2] = comp.lisp_obj_type;
  2981   args[3] = comp.int_type;
  2982   ADD_IMPORTED (set_internal, comp.void_type, 4, args);
  2983 
  2984   args[0] = comp.lisp_obj_type;
  2985   ADD_IMPORTED (helper_unwind_protect, comp.void_type, 1, args);
  2986 
  2987   args[0] = args[1] = comp.lisp_obj_type;
  2988   ADD_IMPORTED (specbind, comp.void_type, 2, args);
  2989 
  2990   ADD_IMPORTED (maybe_gc, comp.void_type, 0, NULL);
  2991 
  2992   ADD_IMPORTED (maybe_quit, comp.void_type, 0, NULL);
  2993 
  2994 #undef ADD_IMPORTED
  2995 
  2996   return Freverse (field_list);
  2997 }
  2998 
  2999 /*
  3000   This emit the code needed by every compilation unit to be loaded.
  3001 */
  3002 static void
  3003 emit_ctxt_code (void)
  3004 {
  3005   /* Emit optimize qualities.  */
  3006   Lisp_Object opt_qly[] =
  3007     { Fcons (Qnative_comp_speed, make_fixnum (comp.speed)),
  3008       Fcons (Qnative_comp_debug, make_fixnum (comp.debug)),
  3009       Fcons (Qgccjit,
  3010              Fcomp_libgccjit_version ()) };
  3011   emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (ARRAYELTS (opt_qly), opt_qly));
  3012 
  3013   emit_static_object (TEXT_FDOC_SYM,
  3014                       CALL1I (comp-ctxt-function-docs, Vcomp_ctxt));
  3015 
  3016   comp.current_thread_ref =
  3017     gcc_jit_lvalue_as_rvalue (
  3018       gcc_jit_context_new_global (
  3019         comp.ctxt,
  3020         NULL,
  3021         GCC_JIT_GLOBAL_EXPORTED,
  3022         gcc_jit_type_get_pointer (comp.thread_state_ptr_type),
  3023         CURRENT_THREAD_RELOC_SYM));
  3024 
  3025   comp.f_symbols_with_pos_enabled_ref =
  3026     gcc_jit_lvalue_as_rvalue (
  3027       gcc_jit_context_new_global (
  3028         comp.ctxt,
  3029         NULL,
  3030         GCC_JIT_GLOBAL_EXPORTED,
  3031         comp.bool_ptr_type,
  3032         F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM));
  3033 
  3034   comp.pure_ptr =
  3035     gcc_jit_lvalue_as_rvalue (
  3036       gcc_jit_context_new_global (
  3037         comp.ctxt,
  3038         NULL,
  3039         GCC_JIT_GLOBAL_EXPORTED,
  3040         comp.void_ptr_type,
  3041         PURE_RELOC_SYM));
  3042 
  3043   gcc_jit_context_new_global (
  3044         comp.ctxt,
  3045         NULL,
  3046         GCC_JIT_GLOBAL_EXPORTED,
  3047         comp.lisp_obj_type,
  3048         COMP_UNIT_SYM);
  3049 
  3050   declare_imported_data ();
  3051 
  3052   /* Functions imported from Lisp code.  */
  3053   freloc_check_fill ();
  3054   gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields));
  3055   ptrdiff_t n_frelocs = 0;
  3056   Lisp_Object f_runtime = declare_runtime_imported_funcs ();
  3057   FOR_EACH_TAIL (f_runtime)
  3058     {
  3059       Lisp_Object el = XCAR (f_runtime);
  3060       eassert (n_frelocs < freloc.size);
  3061       fields[n_frelocs++] = xmint_pointer (XCDR (el));
  3062     }
  3063 
  3064   /* Sign the .eln for the exposed ABI it expects at load.  */
  3065   eassert (!NILP (Vcomp_abi_hash));
  3066   emit_static_object (LINK_TABLE_HASH_SYM, Vcomp_abi_hash);
  3067 
  3068   Lisp_Object subr_l = Vcomp_subr_list;
  3069   FOR_EACH_TAIL (subr_l)
  3070     {
  3071       struct Lisp_Subr *subr = XSUBR (XCAR (subr_l));
  3072       Lisp_Object subr_sym = intern_c_string (subr->symbol_name);
  3073       eassert (n_frelocs < freloc.size);
  3074       fields[n_frelocs++] = declare_imported_func (subr_sym, comp.lisp_obj_type,
  3075                                                    subr->max_args, NULL);
  3076     }
  3077 
  3078   gcc_jit_struct *f_reloc_struct =
  3079     gcc_jit_context_new_struct_type (comp.ctxt,
  3080                                      NULL,
  3081                                      "freloc_link_table",
  3082                                      n_frelocs, fields);
  3083   comp.func_relocs_ptr_type =
  3084     gcc_jit_type_get_pointer (
  3085       gcc_jit_struct_as_type (f_reloc_struct));
  3086 
  3087   comp.func_relocs =
  3088     gcc_jit_context_new_global (comp.ctxt,
  3089                                 NULL,
  3090                                 GCC_JIT_GLOBAL_EXPORTED,
  3091                                 comp.func_relocs_ptr_type,
  3092                                 FUNC_LINK_TABLE_SYM);
  3093 
  3094   xfree (fields);
  3095 }
  3096 
  3097 
  3098 /****************************************************************/
  3099 /* Inline function definition and lisp data structure follows.  */
  3100 /****************************************************************/
  3101 
  3102 /* struct Lisp_Cons definition.  */
  3103 
  3104 static void
  3105 define_lisp_cons (void)
  3106 {
  3107   /*
  3108     union cdr_u
  3109     {
  3110       Lisp_Object cdr;
  3111       struct Lisp_Cons *chain;
  3112     };
  3113 
  3114     struct cons_s
  3115     {
  3116       Lisp_Object car;
  3117       union cdr_u u;
  3118     };
  3119 
  3120     union cons_u
  3121     {
  3122       struct cons_s s;
  3123       char align_pad[sizeof (struct Lisp_Cons)];
  3124     };
  3125 
  3126     struct Lisp_Cons
  3127     {
  3128       union cons_u u;
  3129     };
  3130   */
  3131 
  3132   comp.lisp_cons_s =
  3133     gcc_jit_context_new_opaque_struct (comp.ctxt,
  3134                                        NULL,
  3135                                        "comp_Lisp_Cons");
  3136   comp.lisp_cons_type =
  3137     gcc_jit_struct_as_type (comp.lisp_cons_s);
  3138   comp.lisp_cons_ptr_type =
  3139     gcc_jit_type_get_pointer (comp.lisp_cons_type);
  3140 
  3141   comp.lisp_cons_u_s_u_cdr =
  3142     gcc_jit_context_new_field (comp.ctxt,
  3143                                NULL,
  3144                                comp.lisp_obj_type,
  3145                                "cdr");
  3146 
  3147   gcc_jit_field *cdr_u_fields[] =
  3148     { comp.lisp_cons_u_s_u_cdr,
  3149       gcc_jit_context_new_field (comp.ctxt,
  3150                                  NULL,
  3151                                  comp.lisp_cons_ptr_type,
  3152                                  "chain") };
  3153 
  3154   gcc_jit_type *cdr_u =
  3155     gcc_jit_context_new_union_type (comp.ctxt,
  3156                                     NULL,
  3157                                     "comp_cdr_u",
  3158                                     ARRAYELTS (cdr_u_fields),
  3159                                     cdr_u_fields);
  3160 
  3161   comp.lisp_cons_u_s_car = gcc_jit_context_new_field (comp.ctxt,
  3162                                             NULL,
  3163                                             comp.lisp_obj_type,
  3164                                             "car");
  3165   comp.lisp_cons_u_s_u = gcc_jit_context_new_field (comp.ctxt,
  3166                                                     NULL,
  3167                                                     cdr_u,
  3168                                                     "u");
  3169   gcc_jit_field *cons_s_fields[] =
  3170     { comp.lisp_cons_u_s_car,
  3171       comp.lisp_cons_u_s_u };
  3172 
  3173   gcc_jit_struct *cons_s =
  3174     gcc_jit_context_new_struct_type (comp.ctxt,
  3175                                      NULL,
  3176                                      "comp_cons_s",
  3177                                      ARRAYELTS (cons_s_fields),
  3178                                      cons_s_fields);
  3179 
  3180   comp.lisp_cons_u_s = gcc_jit_context_new_field (comp.ctxt,
  3181                                  NULL,
  3182                                  gcc_jit_struct_as_type (cons_s),
  3183                                  "s");
  3184 
  3185   gcc_jit_field *cons_u_fields[] =
  3186     { comp.lisp_cons_u_s,
  3187       gcc_jit_context_new_field (
  3188         comp.ctxt,
  3189         NULL,
  3190         gcc_jit_context_new_array_type (comp.ctxt,
  3191                                         NULL,
  3192                                         comp.char_type,
  3193                                         sizeof (struct Lisp_Cons)),
  3194         "align_pad") };
  3195 
  3196   gcc_jit_type *lisp_cons_u_type =
  3197     gcc_jit_context_new_union_type (comp.ctxt,
  3198                                     NULL,
  3199                                     "comp_cons_u",
  3200                                     ARRAYELTS (cons_u_fields),
  3201                                     cons_u_fields);
  3202 
  3203   comp.lisp_cons_u =
  3204     gcc_jit_context_new_field (comp.ctxt,
  3205                                NULL,
  3206                                lisp_cons_u_type,
  3207                                "u");
  3208   gcc_jit_struct_set_fields (comp.lisp_cons_s,
  3209                              NULL, 1, &comp.lisp_cons_u);
  3210 
  3211 }
  3212 
  3213 static void
  3214 define_lisp_symbol_with_position (void)
  3215 {
  3216   comp.lisp_symbol_with_position_header =
  3217     gcc_jit_context_new_field (comp.ctxt,
  3218                                NULL,
  3219                                comp.ptrdiff_type,
  3220                                "header");
  3221   comp.lisp_symbol_with_position_sym =
  3222     gcc_jit_context_new_field (comp.ctxt,
  3223                                NULL,
  3224                                comp.lisp_obj_type,
  3225                                "sym");
  3226   comp.lisp_symbol_with_position_pos =
  3227     gcc_jit_context_new_field (comp.ctxt,
  3228                                NULL,
  3229                                comp.lisp_obj_type,
  3230                                "pos");
  3231   gcc_jit_field *fields [3] = {comp.lisp_symbol_with_position_header,
  3232                                comp.lisp_symbol_with_position_sym,
  3233                                comp.lisp_symbol_with_position_pos};
  3234   comp.lisp_symbol_with_position =
  3235     gcc_jit_context_new_struct_type (comp.ctxt,
  3236                                      NULL,
  3237                                      "comp_lisp_symbol_with_position",
  3238                                      3,
  3239                                      fields);
  3240   comp.lisp_symbol_with_position_type =
  3241     gcc_jit_struct_as_type (comp.lisp_symbol_with_position);
  3242   comp.lisp_symbol_with_position_ptr_type =
  3243     gcc_jit_type_get_pointer (comp.lisp_symbol_with_position_type);
  3244 }
  3245 
  3246 /* Opaque jmp_buf definition.  */
  3247 
  3248 static void
  3249 define_jmp_buf (void)
  3250 {
  3251   gcc_jit_field *field =
  3252     gcc_jit_context_new_field (
  3253       comp.ctxt,
  3254       NULL,
  3255       gcc_jit_context_new_array_type (comp.ctxt,
  3256                                       NULL,
  3257                                       comp.char_type,
  3258                                       sizeof (sys_jmp_buf)),
  3259       "stuff");
  3260   comp.jmp_buf_s =
  3261     gcc_jit_context_new_struct_type (comp.ctxt,
  3262                                      NULL,
  3263                                      "comp_jmp_buf",
  3264                                      1, &field);
  3265 }
  3266 
  3267 static void
  3268 define_memcpy (void)
  3269 {
  3270 
  3271   gcc_jit_param *params[] =
  3272     { gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "dest"),
  3273       gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "src"),
  3274       gcc_jit_context_new_param (comp.ctxt, NULL, comp.size_t_type, "n") };
  3275 
  3276   comp.memcpy =
  3277     gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_IMPORTED,
  3278                                   comp.void_ptr_type, "memcpy",
  3279                                   ARRAYELTS (params), params, false);
  3280 }
  3281 
  3282 /* struct handler definition  */
  3283 
  3284 static void
  3285 define_handler_struct (void)
  3286 {
  3287   comp.handler_s =
  3288     gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler");
  3289   comp.handler_ptr_type =
  3290     gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler_s));
  3291 
  3292   comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt,
  3293                                                       NULL,
  3294                                                       gcc_jit_struct_as_type (
  3295                                                         comp.jmp_buf_s),
  3296                                                       "jmp");
  3297   comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt,
  3298                                                       NULL,
  3299                                                       comp.lisp_obj_type,
  3300                                                       "val");
  3301   comp.handler_next_field = gcc_jit_context_new_field (comp.ctxt,
  3302                                                        NULL,
  3303                                                        comp.handler_ptr_type,
  3304                                                        "next");
  3305   gcc_jit_field *fields[] =
  3306     { gcc_jit_context_new_field (
  3307         comp.ctxt,
  3308         NULL,
  3309         gcc_jit_context_new_array_type (comp.ctxt,
  3310                                         NULL,
  3311                                         comp.char_type,
  3312                                         offsetof (struct handler, val)),
  3313         "pad0"),
  3314       comp.handler_val_field,
  3315       comp.handler_next_field,
  3316       gcc_jit_context_new_field (
  3317         comp.ctxt,
  3318         NULL,
  3319         gcc_jit_context_new_array_type (comp.ctxt,
  3320                                         NULL,
  3321                                         comp.char_type,
  3322                                         offsetof (struct handler, jmp)
  3323                                         - offsetof (struct handler, next)
  3324                                         - sizeof (((struct handler *) 0)->next)),
  3325         "pad1"),
  3326       comp.handler_jmp_field,
  3327       gcc_jit_context_new_field (
  3328         comp.ctxt,
  3329         NULL,
  3330         gcc_jit_context_new_array_type (comp.ctxt,
  3331                                         NULL,
  3332                                         comp.char_type,
  3333                                         sizeof (struct handler)
  3334                                         - offsetof (struct handler, jmp)
  3335                                         - sizeof (((struct handler *) 0)->jmp)),
  3336         "pad2") };
  3337   gcc_jit_struct_set_fields (comp.handler_s,
  3338                              NULL,
  3339                              ARRAYELTS (fields),
  3340                              fields);
  3341 
  3342 }
  3343 
  3344 static void
  3345 define_thread_state_struct (void)
  3346 {
  3347   /* Partially opaque definition for `thread_state'.
  3348      Because we need to access just m_handlerlist hopefully this is requires
  3349      less manutention then the full deifnition.  */
  3350 
  3351   comp.m_handlerlist = gcc_jit_context_new_field (comp.ctxt,
  3352                                                   NULL,
  3353                                                   comp.handler_ptr_type,
  3354                                                   "m_handlerlist");
  3355   gcc_jit_field *fields[] =
  3356     { gcc_jit_context_new_field (
  3357         comp.ctxt,
  3358         NULL,
  3359         gcc_jit_context_new_array_type (comp.ctxt,
  3360                                         NULL,
  3361                                         comp.char_type,
  3362                                         offsetof (struct thread_state,
  3363                                                   m_handlerlist)),
  3364         "pad0"),
  3365       comp.m_handlerlist,
  3366       gcc_jit_context_new_field (
  3367         comp.ctxt,
  3368         NULL,
  3369         gcc_jit_context_new_array_type (
  3370           comp.ctxt,
  3371           NULL,
  3372           comp.char_type,
  3373           sizeof (struct thread_state)
  3374           - offsetof (struct thread_state,
  3375                       m_handlerlist)
  3376           - sizeof (((struct thread_state *) 0)->m_handlerlist)),
  3377         "pad1") };
  3378 
  3379   comp.thread_state_s =
  3380     gcc_jit_context_new_struct_type (comp.ctxt,
  3381                                      NULL,
  3382                                      "comp_thread_state",
  3383                                      ARRAYELTS (fields),
  3384                                      fields);
  3385   comp.thread_state_ptr_type =
  3386     gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s));
  3387 }
  3388 
  3389 #ifndef LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast
  3390 static gcc_jit_function *
  3391 define_type_punning (const char *name,
  3392                      gcc_jit_type *from, gcc_jit_field *from_field,
  3393                      gcc_jit_type *to, gcc_jit_field *to_field)
  3394 {
  3395   gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL,
  3396                                                     from, "arg");
  3397   gcc_jit_function *result = gcc_jit_context_new_function (comp.ctxt,
  3398                                NULL,
  3399                                GCC_JIT_FUNCTION_INTERNAL,
  3400                                to,
  3401                                name,
  3402                                1,
  3403                                &param,
  3404                                0);
  3405 
  3406   DECL_BLOCK (entry_block, result);
  3407 
  3408   gcc_jit_lvalue *tmp_union
  3409     = gcc_jit_function_new_local (result,
  3410                                   NULL,
  3411                                   comp.cast_union_type,
  3412                                   "union_cast");
  3413 
  3414   gcc_jit_block_add_assignment (entry_block, NULL,
  3415                                 gcc_jit_lvalue_access_field (tmp_union, NULL,
  3416                                                              from_field),
  3417                                 gcc_jit_param_as_rvalue (param));
  3418 
  3419   gcc_jit_block_end_with_return (entry_block,
  3420                                  NULL,
  3421                                  gcc_jit_rvalue_access_field (
  3422                                    gcc_jit_lvalue_as_rvalue (tmp_union),
  3423                                    NULL, to_field));
  3424 
  3425   return result;
  3426 }
  3427 
  3428 struct cast_type
  3429 {
  3430   gcc_jit_type *type;
  3431   const char *name;
  3432   bool is_ptr;
  3433 };
  3434 
  3435 static gcc_jit_function *
  3436 define_cast_from_to (struct cast_type from, struct cast_type to)
  3437 {
  3438   char *name = format_string ("cast_from_%s_to_%s", from.name, to.name);
  3439   gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL,
  3440                                                     from.type, "arg");
  3441   gcc_jit_function *result
  3442     = gcc_jit_context_new_function (comp.ctxt,
  3443                                     NULL,
  3444                                     GCC_JIT_FUNCTION_INTERNAL,
  3445                                     to.type, name,
  3446                                     1, &param, 0);
  3447   DECL_BLOCK (entry_block, result);
  3448 
  3449   gcc_jit_rvalue *tmp = gcc_jit_param_as_rvalue (param);
  3450   if (from.is_ptr != to.is_ptr)
  3451     {
  3452       if (from.is_ptr)
  3453         {
  3454           tmp = gcc_jit_context_new_cast (comp.ctxt, NULL,
  3455                                           tmp, comp.void_ptr_type);
  3456           tmp = gcc_jit_context_new_call (comp.ctxt, NULL,
  3457                                           comp.cast_ptr_to_int, 1, &tmp);
  3458         }
  3459       else
  3460         {
  3461           tmp = gcc_jit_context_new_cast (comp.ctxt, NULL,
  3462                                           tmp, comp.uintptr_type);
  3463           tmp = gcc_jit_context_new_call (comp.ctxt, NULL,
  3464                                           comp.cast_int_to_ptr, 1, &tmp);
  3465         }
  3466     }
  3467 
  3468   tmp = gcc_jit_context_new_cast (comp.ctxt, NULL, tmp, to.type);
  3469 
  3470   gcc_jit_block_end_with_return (entry_block, NULL, tmp);
  3471 
  3472   return result;
  3473 }
  3474 
  3475 static void
  3476 define_cast_functions (void)
  3477 {
  3478   struct cast_type cast_types[NUM_CAST_TYPES]
  3479     = { { comp.bool_type, "bool", false },
  3480         { comp.char_ptr_type, "char_ptr", true },
  3481         { comp.int_type, "int", false },
  3482         { comp.lisp_cons_ptr_type, "lisp_cons_ptr", true },
  3483         { comp.lisp_obj_ptr_type, "lisp_obj_ptr", true },
  3484         { comp.lisp_word_tag_type, "lisp_word_tag", false },
  3485         { comp.lisp_word_type, "lisp_word", LISP_WORDS_ARE_POINTERS },
  3486         { comp.long_long_type, "long_long", false },
  3487         { comp.long_type, "long", false },
  3488         { comp.ptrdiff_type, "ptrdiff", false },
  3489         { comp.uintptr_type, "uintptr", false },
  3490         { comp.unsigned_long_long_type, "unsigned_long_long", false },
  3491         { comp.unsigned_long_type, "unsigned_long", false },
  3492         { comp.unsigned_type, "unsigned", false },
  3493         { comp.void_ptr_type, "void_ptr", true } };
  3494   gcc_jit_field *cast_union_fields[2];
  3495 
  3496   /* Define the union used for type punning.  */
  3497   cast_union_fields[0] = gcc_jit_context_new_field (comp.ctxt,
  3498                                                     NULL,
  3499                                                     comp.void_ptr_type,
  3500                                                     "void_ptr");
  3501   cast_union_fields[1] = gcc_jit_context_new_field (comp.ctxt,
  3502                                                     NULL,
  3503                                                     comp.uintptr_type,
  3504                                                     "uintptr");
  3505 
  3506   comp.cast_union_type
  3507     = gcc_jit_context_new_union_type (comp.ctxt,
  3508                                       NULL,
  3509                                       "cast_union",
  3510                                       2, cast_union_fields);
  3511 
  3512   comp.cast_ptr_to_int = define_type_punning ("cast_pointer_to_uintptr_t",
  3513                                               comp.void_ptr_type,
  3514                                               cast_union_fields[0],
  3515                                               comp.uintptr_type,
  3516                                               cast_union_fields[1]);
  3517   comp.cast_int_to_ptr = define_type_punning ("cast_uintptr_t_to_pointer",
  3518                                               comp.uintptr_type,
  3519                                               cast_union_fields[1],
  3520                                               comp.void_ptr_type,
  3521                                               cast_union_fields[0]);
  3522 
  3523 
  3524   for (int i = 0; i < NUM_CAST_TYPES; ++i)
  3525     comp.cast_types[i] = cast_types[i].type;
  3526 
  3527   /* Define the cast functions using a matrix.  */
  3528   for (int i = 0; i < NUM_CAST_TYPES; ++i)
  3529     for (int j = 0; j < NUM_CAST_TYPES; ++j)
  3530         comp.cast_functions_from_to[i][j] =
  3531           define_cast_from_to (cast_types[i], cast_types[j]);
  3532 }
  3533 #endif /* !LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast */
  3534 
  3535 static void
  3536 define_CHECK_TYPE (void)
  3537 {
  3538   gcc_jit_param *param[] =
  3539     { gcc_jit_context_new_param (comp.ctxt,
  3540                                  NULL,
  3541                                  comp.int_type,
  3542                                  "ok"),
  3543       gcc_jit_context_new_param (comp.ctxt,
  3544                                  NULL,
  3545                                  comp.lisp_obj_type,
  3546                                  "predicate"),
  3547       gcc_jit_context_new_param (comp.ctxt,
  3548                                  NULL,
  3549                                  comp.lisp_obj_type,
  3550                                  "x") };
  3551   comp.check_type =
  3552     gcc_jit_context_new_function (comp.ctxt, NULL,
  3553                                   GCC_JIT_FUNCTION_INTERNAL,
  3554                                   comp.void_type,
  3555                                   "CHECK_TYPE",
  3556                                   3,
  3557                                   param,
  3558                                   0);
  3559   gcc_jit_rvalue *ok = gcc_jit_param_as_rvalue (param[0]);
  3560   gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]);
  3561   gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]);
  3562 
  3563   DECL_BLOCK (entry_block, comp.check_type);
  3564   DECL_BLOCK (ok_block, comp.check_type);
  3565   DECL_BLOCK (not_ok_block, comp.check_type);
  3566 
  3567   comp.block = entry_block;
  3568   comp.func = comp.check_type;
  3569 
  3570   emit_cond_jump (ok, ok_block, not_ok_block);
  3571 
  3572   gcc_jit_block_end_with_void_return (ok_block, NULL);
  3573 
  3574   comp.block = not_ok_block;
  3575 
  3576   gcc_jit_rvalue *wrong_type_args[] = { predicate, x };
  3577 
  3578   gcc_jit_block_add_eval (comp.block,
  3579                           NULL,
  3580                           emit_call (intern_c_string ("wrong_type_argument"),
  3581                                      comp.void_type, 2, wrong_type_args,
  3582                                      false));
  3583 
  3584   gcc_jit_block_end_with_void_return (not_ok_block, NULL);
  3585 }
  3586 
  3587 /* Define a substitute for CAR as always inlined function.  */
  3588 
  3589 static void
  3590 define_CAR_CDR (void)
  3591 {
  3592   gcc_jit_function *func[2];
  3593   char const *f_name[] = { "CAR", "CDR" };
  3594   for (int i = 0; i < 2; i++)
  3595     {
  3596       gcc_jit_param *param[] =
  3597         { gcc_jit_context_new_param (comp.ctxt,
  3598                                      NULL,
  3599                                      comp.lisp_obj_type,
  3600                                      "c"),
  3601           gcc_jit_context_new_param (comp.ctxt,
  3602                                      NULL,
  3603                                      comp.bool_type,
  3604                                      "cert_cons") };
  3605       /* TODO: understand why after ipa-prop pass gcc is less keen on inlining
  3606          and as consequence can refuse to compile these. (see dhrystone.el)
  3607          Flag this and all the one involved in ipa-prop as
  3608          GCC_JIT_FUNCTION_INTERNAL not to fail compilation in case.
  3609          This seems at least to have no perf downside.  */
  3610       func[i] =
  3611         gcc_jit_context_new_function (comp.ctxt, NULL,
  3612                                       GCC_JIT_FUNCTION_INTERNAL,
  3613                                       comp.lisp_obj_type,
  3614                                       f_name[i],
  3615                                       2, param, 0);
  3616 
  3617       gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param[0]);
  3618       DECL_BLOCK (entry_block, func[i]);
  3619       DECL_BLOCK (is_cons_b, func[i]);
  3620       DECL_BLOCK (not_a_cons_b, func[i]);
  3621       comp.block = entry_block;
  3622       comp.func = func[i];
  3623       emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
  3624                                       comp.bool_type,
  3625                                       gcc_jit_param_as_rvalue (param[1]),
  3626                                       emit_CONSP (c)),
  3627                       is_cons_b,
  3628                       not_a_cons_b);
  3629       comp.block = is_cons_b;
  3630       if (i == 0)
  3631         gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c));
  3632       else
  3633         gcc_jit_block_end_with_return (comp.block, NULL, emit_XCDR (c));
  3634 
  3635       comp.block = not_a_cons_b;
  3636 
  3637       DECL_BLOCK (is_nil_b, func[i]);
  3638       DECL_BLOCK (not_nil_b, func[i]);
  3639 
  3640       emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b);
  3641 
  3642       comp.block = is_nil_b;
  3643       gcc_jit_block_end_with_return (comp.block,
  3644                                      NULL,
  3645                                      emit_lisp_obj_rval (Qnil));
  3646 
  3647       comp.block = not_nil_b;
  3648       gcc_jit_rvalue *wrong_type_args[] =
  3649         { emit_lisp_obj_rval (Qlistp), c };
  3650 
  3651       gcc_jit_block_add_eval (comp.block,
  3652                               NULL,
  3653                               emit_call (intern_c_string ("wrong_type_argument"),
  3654                                          comp.void_type, 2, wrong_type_args,
  3655                                          false));
  3656       gcc_jit_block_end_with_return (comp.block,
  3657                                      NULL,
  3658                                      emit_lisp_obj_rval (Qnil));
  3659     }
  3660   comp.car = func[0];
  3661   comp.cdr = func[1];
  3662 }
  3663 
  3664 static void
  3665 define_setcar_setcdr (void)
  3666 {
  3667   char const *f_name[] = { "setcar", "setcdr" };
  3668   char const *par_name[] = { "new_car", "new_cdr" };
  3669 
  3670   for (int i = 0; i < 2; i++)
  3671     {
  3672       gcc_jit_param *cell =
  3673         gcc_jit_context_new_param (comp.ctxt,
  3674                                    NULL,
  3675                                    comp.lisp_obj_type,
  3676                                    "cell");
  3677       gcc_jit_param *new_el =
  3678         gcc_jit_context_new_param (comp.ctxt,
  3679                                    NULL,
  3680                                    comp.lisp_obj_type,
  3681                                    par_name[i]);
  3682 
  3683       gcc_jit_param *param[] =
  3684         { cell,
  3685           new_el,
  3686           gcc_jit_context_new_param (comp.ctxt,
  3687                                      NULL,
  3688                                      comp.bool_type,
  3689                                      "cert_cons") };
  3690 
  3691       gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr;
  3692       *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL,
  3693                                              GCC_JIT_FUNCTION_INTERNAL,
  3694                                              comp.lisp_obj_type,
  3695                                              f_name[i],
  3696                                              3, param, 0);
  3697       DECL_BLOCK (entry_block, *f_ref);
  3698       comp.func = *f_ref;
  3699       comp.block = entry_block;
  3700 
  3701       /* CHECK_CONS (cell);  */
  3702       emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell));
  3703 
  3704       /* CHECK_IMPURE (cell, XCONS (cell));  */
  3705       gcc_jit_rvalue *args[] =
  3706         { gcc_jit_param_as_rvalue (cell),
  3707           emit_XCONS (gcc_jit_param_as_rvalue (cell)) };
  3708 
  3709       gcc_jit_block_add_eval (entry_block,
  3710                               NULL,
  3711                               gcc_jit_context_new_call (comp.ctxt,
  3712                                                         NULL,
  3713                                                         comp.check_impure,
  3714                                                         2,
  3715                                                         args));
  3716 
  3717       /* XSETCDR (cell, newel);  */
  3718       if (!i)
  3719         emit_XSETCAR (gcc_jit_param_as_rvalue (cell),
  3720                       gcc_jit_param_as_rvalue (new_el));
  3721       else
  3722         emit_XSETCDR (gcc_jit_param_as_rvalue (cell),
  3723                       gcc_jit_param_as_rvalue (new_el));
  3724 
  3725       /* return newel;  */
  3726       gcc_jit_block_end_with_return (entry_block,
  3727                                      NULL,
  3728                                      gcc_jit_param_as_rvalue (new_el));
  3729     }
  3730 }
  3731 
  3732 /*
  3733    Define a substitute for Fadd1 Fsub1.
  3734    Currently expose just fixnum arithmetic.
  3735 */
  3736 
  3737 static void
  3738 define_add1_sub1 (void)
  3739 {
  3740   gcc_jit_block *bb_orig = comp.block;
  3741   gcc_jit_function *func[2];
  3742   char const *f_name[] = { "add1", "sub1" };
  3743   char const *fall_back_func[] = { "1+", "1-" };
  3744   enum gcc_jit_binary_op op[] =
  3745     { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS };
  3746   for (ptrdiff_t i = 0; i < 2; i++)
  3747     {
  3748       gcc_jit_param *param[] =
  3749         { gcc_jit_context_new_param (comp.ctxt,
  3750                                      NULL,
  3751                                      comp.lisp_obj_type,
  3752                                      "n"),
  3753           gcc_jit_context_new_param (comp.ctxt,
  3754                                      NULL,
  3755                                      comp.bool_type,
  3756                                      "cert_fixnum") };
  3757       comp.func = func[i] =
  3758         gcc_jit_context_new_function (comp.ctxt, NULL,
  3759                                       GCC_JIT_FUNCTION_INTERNAL,
  3760                                       comp.lisp_obj_type,
  3761                                       f_name[i],
  3762                                       2,
  3763                                       param, 0);
  3764       DECL_BLOCK (entry_block, func[i]);
  3765       DECL_BLOCK (inline_block, func[i]);
  3766       DECL_BLOCK (fcall_block, func[i]);
  3767 
  3768       comp.block = entry_block;
  3769 
  3770       /* cert_fixnum ||
  3771          ((FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM
  3772          ? (XFIXNUM (n) + 1)
  3773          : Fadd1 (n)) */
  3774 
  3775       gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]);
  3776       gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n);
  3777       gcc_jit_rvalue *sure_fixnum =
  3778         emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
  3779                         comp.bool_type,
  3780                         gcc_jit_param_as_rvalue (param[1]),
  3781                         emit_FIXNUMP (n));
  3782       emit_cond_jump (
  3783         emit_binary_op (
  3784           GCC_JIT_BINARY_OP_LOGICAL_AND,
  3785           comp.bool_type,
  3786           sure_fixnum,
  3787           gcc_jit_context_new_comparison (
  3788             comp.ctxt,
  3789             NULL,
  3790             GCC_JIT_COMPARISON_NE,
  3791             n_fixnum,
  3792             i == 0
  3793             ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM)
  3794             : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))),
  3795         inline_block,
  3796         fcall_block);
  3797 
  3798       comp.block = inline_block;
  3799       gcc_jit_rvalue *inline_res =
  3800         emit_binary_op (op[i], comp.emacs_int_type, n_fixnum, comp.one);
  3801 
  3802       gcc_jit_block_end_with_return (inline_block,
  3803                                      NULL,
  3804                                      emit_make_fixnum (inline_res));
  3805 
  3806       comp.block = fcall_block;
  3807       gcc_jit_rvalue *call_res = emit_call (intern_c_string (fall_back_func[i]),
  3808                                             comp.lisp_obj_type, 1, &n, false);
  3809       gcc_jit_block_end_with_return (fcall_block,
  3810                                      NULL,
  3811                                      call_res);
  3812     }
  3813   comp.block = bb_orig;
  3814   comp.add1 = func[0];
  3815   comp.sub1 = func[1];
  3816 }
  3817 
  3818 static void
  3819 define_negate (void)
  3820 {
  3821   gcc_jit_block *bb_orig = comp.block;
  3822   gcc_jit_param *param[] =
  3823         { gcc_jit_context_new_param (comp.ctxt,
  3824                                      NULL,
  3825                                      comp.lisp_obj_type,
  3826                                      "n"),
  3827           gcc_jit_context_new_param (comp.ctxt,
  3828                                      NULL,
  3829                                      comp.bool_type,
  3830                                      "cert_fixnum") };
  3831 
  3832   comp.func = comp.negate =
  3833     gcc_jit_context_new_function (comp.ctxt, NULL,
  3834                                   GCC_JIT_FUNCTION_INTERNAL,
  3835                                   comp.lisp_obj_type,
  3836                                   "negate",
  3837                                   2, param, 0);
  3838 
  3839   DECL_BLOCK (entry_block, comp.negate);
  3840   DECL_BLOCK (inline_block, comp.negate);
  3841   DECL_BLOCK (fcall_block, comp.negate);
  3842 
  3843   comp.block = entry_block;
  3844 
  3845   /* (cert_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM
  3846      ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP))  */
  3847 
  3848   gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]);
  3849   gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n));
  3850   gcc_jit_rvalue *sure_fixnum =
  3851     emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
  3852                     comp.bool_type,
  3853                     gcc_jit_param_as_rvalue (param[1]),
  3854                     emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)));
  3855 
  3856   emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_AND,
  3857                                   comp.bool_type,
  3858                                   sure_fixnum,
  3859                                   gcc_jit_context_new_comparison (
  3860                                     comp.ctxt,
  3861                                     NULL,
  3862                                     GCC_JIT_COMPARISON_NE,
  3863                                     n_fixnum,
  3864                                     emit_rvalue_from_emacs_int (
  3865                                       MOST_NEGATIVE_FIXNUM))),
  3866                   inline_block,
  3867                   fcall_block);
  3868 
  3869   comp.block = inline_block;
  3870   gcc_jit_rvalue *inline_res =
  3871     gcc_jit_context_new_unary_op (comp.ctxt,
  3872                                   NULL,
  3873                                   GCC_JIT_UNARY_OP_MINUS,
  3874                                   comp.emacs_int_type,
  3875                                   n_fixnum);
  3876 
  3877   gcc_jit_block_end_with_return (inline_block,
  3878                                  NULL,
  3879                                  emit_make_fixnum (inline_res));
  3880 
  3881   comp.block = fcall_block;
  3882   gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n, false);
  3883   gcc_jit_block_end_with_return (fcall_block,
  3884                                  NULL,
  3885                                  call_res);
  3886   comp.block = bb_orig;
  3887 }
  3888 
  3889 /* Define a substitute for PSEUDOVECTORP as always inlined function.  */
  3890 
  3891 static void
  3892 define_PSEUDOVECTORP (void)
  3893 {
  3894   gcc_jit_param *param[] =
  3895     { gcc_jit_context_new_param (comp.ctxt,
  3896                                  NULL,
  3897                                  comp.lisp_obj_type,
  3898                                  "a"),
  3899       gcc_jit_context_new_param (comp.ctxt,
  3900                                  NULL,
  3901                                  comp.int_type,
  3902                                  "code") };
  3903 
  3904   comp.pseudovectorp =
  3905     gcc_jit_context_new_function (comp.ctxt, NULL,
  3906                                   GCC_JIT_FUNCTION_INTERNAL,
  3907                                   comp.bool_type,
  3908                                   "PSEUDOVECTORP",
  3909                                   2,
  3910                                   param,
  3911                                   0);
  3912 
  3913   DECL_BLOCK (entry_block, comp.pseudovectorp);
  3914   DECL_BLOCK (ret_false_b, comp.pseudovectorp);
  3915   DECL_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp);
  3916 
  3917   comp.block = entry_block;
  3918   comp.func = comp.pseudovectorp;
  3919 
  3920   emit_cond_jump (emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0])),
  3921                   call_pseudovector_typep_b,
  3922                   ret_false_b);
  3923 
  3924   comp.block = ret_false_b;
  3925   gcc_jit_block_end_with_return (ret_false_b,
  3926                                  NULL,
  3927                                  gcc_jit_context_new_rvalue_from_int (
  3928                                    comp.ctxt,
  3929                                    comp.bool_type,
  3930                                    false));
  3931 
  3932   gcc_jit_rvalue *args[] =
  3933     { gcc_jit_param_as_rvalue (param[0]),
  3934       gcc_jit_param_as_rvalue (param[1]) };
  3935   comp.block = call_pseudovector_typep_b;
  3936   /* FIXME use XUNTAG now that's available.  */
  3937   gcc_jit_block_end_with_return (
  3938     call_pseudovector_typep_b,
  3939     NULL,
  3940     emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"),
  3941                comp.bool_type, 2, args, false));
  3942 }
  3943 
  3944 static void
  3945 define_GET_SYMBOL_WITH_POSITION (void)
  3946 {
  3947   gcc_jit_param *param[] =
  3948     { gcc_jit_context_new_param (comp.ctxt,
  3949                                  NULL,
  3950                                  comp.lisp_obj_type,
  3951                                  "a") };
  3952 
  3953   comp.get_symbol_with_position =
  3954     gcc_jit_context_new_function (comp.ctxt, NULL,
  3955                                   GCC_JIT_FUNCTION_INTERNAL,
  3956                                   comp.lisp_symbol_with_position_ptr_type,
  3957                                   "GET_SYMBOL_WITH_POSITION",
  3958                                   1,
  3959                                   param,
  3960                                   0);
  3961 
  3962   DECL_BLOCK (entry_block, comp.get_symbol_with_position);
  3963 
  3964   comp.block = entry_block;
  3965   comp.func = comp.get_symbol_with_position;
  3966 
  3967   gcc_jit_rvalue *args[] =
  3968     { gcc_jit_param_as_rvalue (param[0]) };
  3969   /* FIXME use XUNTAG now that's available.  */
  3970   gcc_jit_block_end_with_return (
  3971     entry_block,
  3972     NULL,
  3973     emit_call (intern_c_string ("helper_GET_SYMBOL_WITH_POSITION"),
  3974                comp.lisp_symbol_with_position_ptr_type,
  3975                1, args, false));
  3976 }
  3977 
  3978 static void define_SYMBOL_WITH_POS_SYM (void)
  3979 {
  3980   gcc_jit_rvalue *tmpr, *swp;
  3981   gcc_jit_lvalue *tmpl;
  3982 
  3983   gcc_jit_param *param [] =
  3984     { gcc_jit_context_new_param (comp.ctxt,
  3985                                  NULL,
  3986                                  comp.lisp_obj_type,
  3987                                  "a") };
  3988   comp.symbol_with_pos_sym =
  3989     gcc_jit_context_new_function (comp.ctxt, NULL,
  3990                                   GCC_JIT_FUNCTION_INTERNAL,
  3991                                   comp.lisp_obj_type,
  3992                                   "SYMBOL_WITH_POS_SYM",
  3993                                   1,
  3994                                   param,
  3995                                   0);
  3996 
  3997   DECL_BLOCK (entry_block, comp.symbol_with_pos_sym);
  3998   comp.func = comp.symbol_with_pos_sym;
  3999   comp.block = entry_block;
  4000 
  4001   emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0]));
  4002 
  4003   gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param [0]) };
  4004 
  4005   swp = gcc_jit_context_new_call (comp.ctxt,
  4006                                   NULL,
  4007                                   comp.get_symbol_with_position,
  4008                                   1,
  4009                                   args);
  4010   tmpl = gcc_jit_rvalue_dereference (swp, NULL);
  4011   tmpr = gcc_jit_lvalue_as_rvalue (tmpl);
  4012   gcc_jit_block_end_with_return (entry_block,
  4013                                  NULL,
  4014                                  gcc_jit_rvalue_access_field (
  4015                                    tmpr,
  4016                                    NULL,
  4017                                    comp.lisp_symbol_with_position_sym));
  4018 }
  4019 
  4020 static void
  4021 define_CHECK_IMPURE (void)
  4022 {
  4023   gcc_jit_param *param[] =
  4024     { gcc_jit_context_new_param (comp.ctxt,
  4025                                  NULL,
  4026                                  comp.lisp_obj_type,
  4027                                  "obj"),
  4028       gcc_jit_context_new_param (comp.ctxt,
  4029                                  NULL,
  4030                                  comp.void_ptr_type,
  4031                                  "ptr") };
  4032   comp.check_impure =
  4033     gcc_jit_context_new_function (comp.ctxt, NULL,
  4034                                   GCC_JIT_FUNCTION_INTERNAL,
  4035                                   comp.void_type,
  4036                                   "CHECK_IMPURE",
  4037                                   2,
  4038                                   param,
  4039                                   0);
  4040 
  4041     DECL_BLOCK (entry_block, comp.check_impure);
  4042     DECL_BLOCK (err_block, comp.check_impure);
  4043     DECL_BLOCK (ok_block, comp.check_impure);
  4044 
  4045     comp.block = entry_block;
  4046     comp.func = comp.check_impure;
  4047 
  4048     emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */
  4049                     err_block,
  4050                     ok_block);
  4051     gcc_jit_block_end_with_void_return (ok_block, NULL);
  4052 
  4053     gcc_jit_rvalue *pure_write_error_arg =
  4054       gcc_jit_param_as_rvalue (param[0]);
  4055 
  4056     comp.block = err_block;
  4057     gcc_jit_block_add_eval (comp.block,
  4058                             NULL,
  4059                             emit_call (intern_c_string ("pure_write_error"),
  4060                                        comp.void_type, 1,&pure_write_error_arg,
  4061                                        false));
  4062 
  4063     gcc_jit_block_end_with_void_return (err_block, NULL);
  4064 }
  4065 
  4066 static void
  4067 define_maybe_gc_or_quit (void)
  4068 {
  4069 
  4070   /*
  4071     void
  4072     maybe_gc_or_quit (void)
  4073     {
  4074       static unsigned quitcounter;
  4075      inc:
  4076       quitcounter++;
  4077       if (quitcounter >> 14) goto maybe_do_it else goto pass;
  4078      maybe_do_it:
  4079           quitcounter = 0;
  4080           maybe_gc ();
  4081           maybe_quit ();
  4082           return;
  4083      pass:
  4084           return;
  4085     }
  4086   */
  4087 
  4088   gcc_jit_block *bb_orig = comp.block;
  4089 
  4090   gcc_jit_lvalue *quitcounter =
  4091     gcc_jit_context_new_global (
  4092       comp.ctxt,
  4093       NULL,
  4094       GCC_JIT_GLOBAL_INTERNAL,
  4095       comp.unsigned_type,
  4096       "quitcounter");
  4097 
  4098   comp.func = comp.maybe_gc_or_quit =
  4099     gcc_jit_context_new_function (comp.ctxt, NULL,
  4100                                   GCC_JIT_FUNCTION_INTERNAL,
  4101                                   comp.void_type,
  4102                                   "maybe_gc_quit",
  4103                                   0, NULL, 0);
  4104   DECL_BLOCK (increment_block, comp.maybe_gc_or_quit);
  4105   DECL_BLOCK (maybe_do_it_block, comp.maybe_gc_or_quit);
  4106   DECL_BLOCK (pass_block, comp.maybe_gc_or_quit);
  4107 
  4108   comp.block = increment_block;
  4109 
  4110   gcc_jit_block_add_assignment (
  4111     comp.block,
  4112     NULL,
  4113     quitcounter,
  4114     emit_binary_op (GCC_JIT_BINARY_OP_PLUS,
  4115                     comp.unsigned_type,
  4116                     gcc_jit_lvalue_as_rvalue (quitcounter),
  4117                     gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  4118                                                          comp.unsigned_type,
  4119                                                          1)));
  4120   emit_cond_jump (
  4121     emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
  4122                     comp.unsigned_type,
  4123                     gcc_jit_lvalue_as_rvalue (quitcounter),
  4124                     gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  4125                                                          comp.unsigned_type,
  4126                                                          9)),
  4127     /* 9 translates into checking for GC or quit every 512 calls to
  4128        'maybe_gc_quit'.  This is the smallest value I could find with
  4129        no performance impact running elisp-banechmarks and the same
  4130        used by the byte interpreter (see 'exec_byte_code').  */
  4131     maybe_do_it_block,
  4132     pass_block);
  4133 
  4134   comp.block = maybe_do_it_block;
  4135 
  4136   gcc_jit_block_add_assignment (
  4137     comp.block,
  4138     NULL,
  4139     quitcounter,
  4140     gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  4141                                          comp.unsigned_type,
  4142                                          0));
  4143   gcc_jit_block_add_eval (comp.block, NULL,
  4144                           emit_call (intern_c_string ("maybe_gc"),
  4145                                      comp.void_type, 0, NULL, false));
  4146   gcc_jit_block_add_eval (comp.block, NULL,
  4147                           emit_call (intern_c_string ("maybe_quit"),
  4148                                      comp.void_type, 0, NULL, false));
  4149   gcc_jit_block_end_with_void_return (comp.block, NULL);
  4150 
  4151   gcc_jit_block_end_with_void_return (pass_block, NULL);
  4152 
  4153   comp.block = bb_orig;
  4154 }
  4155 
  4156 /* Define a function to convert boolean into t or nil */
  4157 
  4158 static void
  4159 define_bool_to_lisp_obj (void)
  4160 {
  4161   /* x ? Qt : Qnil */
  4162   gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt,
  4163                                                     NULL,
  4164                                                     comp.bool_type,
  4165                                                     "x");
  4166   comp.bool_to_lisp_obj =
  4167     gcc_jit_context_new_function (comp.ctxt, NULL,
  4168                                   GCC_JIT_FUNCTION_INTERNAL,
  4169                                   comp.lisp_obj_type,
  4170                                   "bool_to_lisp_obj",
  4171                                   1,
  4172                                   &param,
  4173                                   0);
  4174   DECL_BLOCK (entry_block, comp.bool_to_lisp_obj);
  4175   DECL_BLOCK (ret_t_block, comp.bool_to_lisp_obj);
  4176   DECL_BLOCK (ret_nil_block, comp.bool_to_lisp_obj);
  4177   comp.block = entry_block;
  4178   comp.func = comp.bool_to_lisp_obj;
  4179 
  4180   emit_cond_jump (gcc_jit_param_as_rvalue (param),
  4181                   ret_t_block,
  4182                   ret_nil_block);
  4183 
  4184   comp.block = ret_t_block;
  4185   gcc_jit_block_end_with_return (ret_t_block,
  4186                                  NULL,
  4187                                  emit_lisp_obj_rval (Qt));
  4188 
  4189   comp.block = ret_nil_block;
  4190   gcc_jit_block_end_with_return (ret_nil_block,
  4191                                  NULL,
  4192                                  emit_lisp_obj_rval (Qnil));
  4193 }
  4194 
  4195 static gcc_jit_function *
  4196 declare_lex_function (Lisp_Object func)
  4197 {
  4198   gcc_jit_function *res;
  4199   Lisp_Object c_name = CALL1I (comp-func-c-name, func);
  4200   Lisp_Object args = CALL1I (comp-func-l-args, func);
  4201   bool nargs = !NILP (CALL1I (comp-nargs-p, args));
  4202   USE_SAFE_ALLOCA;
  4203 
  4204   if (!nargs)
  4205     {
  4206       EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args));
  4207       eassert (max_args < INT_MAX);
  4208       gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type));
  4209       for (ptrdiff_t i = 0; i < max_args; i++)
  4210         type[i] = comp.lisp_obj_type;
  4211 
  4212       gcc_jit_param **params = SAFE_ALLOCA (max_args * sizeof (*params));
  4213       for (int i = 0; i < max_args; ++i)
  4214         params[i] = gcc_jit_context_new_param (comp.ctxt,
  4215                                               NULL,
  4216                                               type[i],
  4217                                               format_string ("par_%d", i));
  4218       res = gcc_jit_context_new_function (comp.ctxt, NULL,
  4219                                           GCC_JIT_FUNCTION_EXPORTED,
  4220                                           comp.lisp_obj_type,
  4221                                           SSDATA (c_name),
  4222                                           max_args,
  4223                                           params,
  4224                                           0);
  4225     }
  4226   else
  4227     {
  4228       gcc_jit_param *params[] =
  4229         { gcc_jit_context_new_param (comp.ctxt,
  4230                                      NULL,
  4231                                      comp.ptrdiff_type,
  4232                                      "nargs"),
  4233           gcc_jit_context_new_param (comp.ctxt,
  4234                                      NULL,
  4235                                      comp.lisp_obj_ptr_type,
  4236                                      "args") };
  4237       res =
  4238         gcc_jit_context_new_function (comp.ctxt,
  4239                                       NULL,
  4240                                       GCC_JIT_FUNCTION_EXPORTED,
  4241                                       comp.lisp_obj_type,
  4242                                       SSDATA (c_name),
  4243                                       ARRAYELTS (params), params, 0);
  4244     }
  4245   SAFE_FREE ();
  4246   return res;
  4247 }
  4248 
  4249 /* Declare a function being compiled and add it to comp.exported_funcs_h.  */
  4250 
  4251 static void
  4252 declare_function (Lisp_Object func)
  4253 {
  4254   gcc_jit_function *gcc_func =
  4255     !NILP (CALL1I (comp-func-l-p, func))
  4256     ? declare_lex_function (func)
  4257     : gcc_jit_context_new_function (comp.ctxt,
  4258                                     NULL,
  4259                                     GCC_JIT_FUNCTION_EXPORTED,
  4260                                     comp.lisp_obj_type,
  4261                                     SSDATA (CALL1I (comp-func-c-name, func)),
  4262                                     0, NULL, 0);
  4263   Fputhash (CALL1I (comp-func-c-name, func),
  4264             make_mint_ptr (gcc_func),
  4265             comp.exported_funcs_h);
  4266 }
  4267 
  4268 static void
  4269 compile_function (Lisp_Object func)
  4270 {
  4271   USE_SAFE_ALLOCA;
  4272   comp.frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func));
  4273   eassert (comp.frame_size < INT_MAX);
  4274 
  4275   comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func),
  4276                                        comp.exported_funcs_h, Qnil));
  4277 
  4278   comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func));
  4279   comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func));
  4280 
  4281   comp.func_relocs_local =
  4282     gcc_jit_function_new_local (comp.func,
  4283                                 NULL,
  4284                                 comp.func_relocs_ptr_type,
  4285                                 "freloc");
  4286 
  4287   comp.frame = SAFE_ALLOCA (comp.frame_size * sizeof (*comp.frame));
  4288   if (comp.func_has_non_local || !comp.func_speed)
  4289     {
  4290       /* FIXME: See bug#42360.  */
  4291       gcc_jit_lvalue *arr =
  4292         gcc_jit_function_new_local (
  4293           comp.func,
  4294           NULL,
  4295           gcc_jit_context_new_array_type (comp.ctxt,
  4296                                           NULL,
  4297                                           comp.lisp_obj_type,
  4298                                           comp.frame_size),
  4299           "frame");
  4300 
  4301       for (ptrdiff_t i = 0; i < comp.frame_size; ++i)
  4302         comp.frame[i] =
  4303           gcc_jit_context_new_array_access (
  4304             comp.ctxt,
  4305             NULL,
  4306             gcc_jit_lvalue_as_rvalue (arr),
  4307             gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  4308                                                  comp.int_type,
  4309                                                  i));
  4310     }
  4311   else
  4312     for (ptrdiff_t i = 0; i < comp.frame_size; ++i)
  4313       comp.frame[i] =
  4314         gcc_jit_function_new_local (comp.func,
  4315                                     NULL,
  4316                                     comp.lisp_obj_type,
  4317                                     format_string ("slot_%td", i));
  4318 
  4319   comp.scratch = NULL;
  4320 
  4321   comp.loc_handler =  gcc_jit_function_new_local (comp.func,
  4322                                                   NULL,
  4323                                                   comp.handler_ptr_type,
  4324                                                   "c");
  4325 
  4326   comp.func_blocks_h = CALLN (Fmake_hash_table);
  4327 
  4328   /* Pre-declare all basic blocks to gcc.
  4329      The "entry" block must be declared as first.  */
  4330   declare_block (Qentry);
  4331   Lisp_Object blocks = CALL1I (comp-func-blocks, func);
  4332   struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks);
  4333   for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
  4334     {
  4335       Lisp_Object block_name = HASH_KEY (ht, i);
  4336       if (!EQ (block_name, Qentry)
  4337           && !BASE_EQ (block_name, Qunbound))
  4338         declare_block (block_name);
  4339     }
  4340 
  4341   gcc_jit_block_add_assignment (retrive_block (Qentry),
  4342                                 NULL,
  4343                                 comp.func_relocs_local,
  4344                                 gcc_jit_lvalue_as_rvalue (comp.func_relocs));
  4345 
  4346 
  4347   for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
  4348     {
  4349       Lisp_Object block_name = HASH_KEY (ht, i);
  4350       if (!BASE_EQ (block_name, Qunbound))
  4351         {
  4352           Lisp_Object block = HASH_VALUE (ht, i);
  4353           Lisp_Object insns = CALL1I (comp-block-insns, block);
  4354           if (NILP (block) || NILP (insns))
  4355             xsignal1 (Qnative_ice,
  4356                       build_string ("basic block is missing or empty"));
  4357 
  4358           comp.block = retrive_block (block_name);
  4359           while (CONSP (insns))
  4360             {
  4361               Lisp_Object insn = XCAR (insns);
  4362               emit_limple_insn (insn);
  4363               insns = XCDR (insns);
  4364             }
  4365         }
  4366     }
  4367   const char *err =  gcc_jit_context_get_first_error (comp.ctxt);
  4368   if (err)
  4369     xsignal3 (Qnative_ice,
  4370               build_string ("failing to compile function"),
  4371               CALL1I (comp-func-name, func),
  4372               build_string (err));
  4373   SAFE_FREE ();
  4374 }
  4375 
  4376 
  4377 /**********************************/
  4378 /* Entry points exposed to lisp.  */
  4379 /**********************************/
  4380 
  4381 /* In use by Fcomp_el_to_eln_filename.  */
  4382 static Lisp_Object loadsearch_re_list;
  4383 
  4384 static Lisp_Object
  4385 make_directory_wrapper (Lisp_Object directory)
  4386 {
  4387   CALL2I (make-directory, directory, Qt);
  4388   return Qnil;
  4389 }
  4390 
  4391 static Lisp_Object
  4392 make_directory_wrapper_1 (Lisp_Object ignore)
  4393 {
  4394   return Qt;
  4395 }
  4396 
  4397 DEFUN ("comp-el-to-eln-rel-filename", Fcomp_el_to_eln_rel_filename,
  4398        Scomp_el_to_eln_rel_filename, 1, 1, 0,
  4399        doc: /* Return the relative name of the .eln file for FILENAME.
  4400 FILENAME must exist, and if it's a symlink, the target must exist.
  4401 If FILENAME is compressed, it must have the \".gz\" extension,
  4402 and Emacs must have been compiled with zlib; the file will be
  4403 uncompressed on the fly to hash its contents.
  4404 Value includes the original base name, followed by 2 hash values,
  4405 one for the file name and another for its contents, followed by .eln.  */)
  4406   (Lisp_Object filename)
  4407 {
  4408   CHECK_STRING (filename);
  4409 
  4410   /* Resolve possible symlinks in FILENAME, so that path_hash below
  4411      always compares equal. (Bug#44701).  */
  4412   filename = Fexpand_file_name (filename, Qnil);
  4413   char *file_normalized = realpath (SSDATA (ENCODE_FILE (filename)), NULL);
  4414   if (file_normalized)
  4415     {
  4416       filename = DECODE_FILE (make_unibyte_string (file_normalized,
  4417                                                    strlen (file_normalized)));
  4418       xfree (file_normalized);
  4419     }
  4420 
  4421   if (NILP (Ffile_exists_p (filename)))
  4422     xsignal1 (Qfile_missing, filename);
  4423 
  4424 #ifdef WINDOWSNT
  4425   filename = Fw32_long_file_name (filename);
  4426 #endif
  4427 
  4428   Lisp_Object content_hash = comp_hash_source_file (filename);
  4429 
  4430   if (suffix_p (filename, ".gz"))
  4431     filename = Fsubstring (filename, Qnil, make_fixnum (-3));
  4432 
  4433   /* We create eln filenames with an hash in order to look-up these
  4434      starting from the source filename, IOW have a relation
  4435 
  4436      /absolute/path/filename.el + content ->
  4437      eln-cache/filename-path_hash-content_hash.eln.
  4438 
  4439      'dlopen' can return the same handle if two shared with the same
  4440      filename are loaded in two different times (even if the first was
  4441      deleted!).  To prevent this scenario the source file content is
  4442      included in the hashing algorithm.
  4443 
  4444      As at any point in time no more then one file can exist with the
  4445      same filename, should be possible to clean up all
  4446      filename-path_hash-* except the most recent one (or the new one
  4447      being recompiled).
  4448 
  4449      As installing .eln files compiled during the build changes their
  4450      absolute path we need an hashing mechanism that is not sensitive
  4451      to that.  For this we replace if match PATH_DUMPLOADSEARCH or
  4452      *PATH_REL_LOADSEARCH with '//' before computing the hash.  */
  4453 
  4454   if (NILP (loadsearch_re_list))
  4455     {
  4456       Lisp_Object sys_re =
  4457         concat2 (build_string ("\\`[[:ascii:]]+"),
  4458                  Fregexp_quote (build_string ("/" PATH_REL_LOADSEARCH "/")));
  4459       Lisp_Object dump_load_search =
  4460         Fexpand_file_name (build_string (PATH_DUMPLOADSEARCH "/"), Qnil);
  4461 #ifdef WINDOWSNT
  4462       dump_load_search = Fw32_long_file_name (dump_load_search);
  4463 #endif
  4464       loadsearch_re_list = list2 (sys_re, Fregexp_quote (dump_load_search));
  4465     }
  4466 
  4467   Lisp_Object lds_re_tail = loadsearch_re_list;
  4468   FOR_EACH_TAIL (lds_re_tail)
  4469     {
  4470       Lisp_Object match_idx =
  4471         Fstring_match (XCAR (lds_re_tail), filename, Qnil, Qnil);
  4472       if (BASE_EQ (match_idx, make_fixnum (0)))
  4473         {
  4474           filename =
  4475             Freplace_match (build_string ("//"), Qt, Qt, filename, Qnil);
  4476           break;
  4477         }
  4478     }
  4479   Lisp_Object separator = build_string ("-");
  4480   Lisp_Object path_hash = comp_hash_string (filename);
  4481   filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil,
  4482                                                            make_fixnum (-3))),
  4483                       separator);
  4484   Lisp_Object hash = concat3 (path_hash, separator, content_hash);
  4485   return concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX));
  4486 }
  4487 
  4488 DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename,
  4489        Scomp_el_to_eln_filename, 1, 2, 0,
  4490        doc: /* Return the absolute .eln file name for source FILENAME.
  4491 The resulting .eln file name is intended to be used for natively
  4492 compiling FILENAME.  FILENAME must exist and be readable, but other
  4493 than that, its leading directories are ignored when constructing
  4494 the name of the .eln file.
  4495 If BASE-DIR is non-nil, use it as the directory for the .eln file;
  4496 non-absolute BASE-DIR is interpreted as relative to `invocation-directory'.
  4497 If BASE-DIR is omitted or nil, look for the first writable directory
  4498 in `native-comp-eln-load-path', and use as BASE-DIR its subdirectory
  4499 whose name is given by `comp-native-version-dir'.
  4500 If FILENAME specifies a preloaded file, the directory for the .eln
  4501 file is the \"preloaded/\" subdirectory of the directory determined
  4502 as described above.  FILENAME is considered to be a preloaded file if
  4503 the value of `comp-file-preloaded-p' is non-nil, or if FILENAME
  4504 appears in the value of the environment variable LISP_PRELOADED;
  4505 the latter is supposed to be used by the Emacs build procedure.  */)
  4506   (Lisp_Object filename, Lisp_Object base_dir)
  4507 {
  4508   Lisp_Object source_filename = filename;
  4509   filename = Fcomp_el_to_eln_rel_filename (filename);
  4510 
  4511   /* If base_dir was not specified search inside Vnative_comp_eln_load_path
  4512      for the first directory where we have write access.  */
  4513   if (NILP (base_dir))
  4514     {
  4515       Lisp_Object eln_load_paths = Vnative_comp_eln_load_path;
  4516       FOR_EACH_TAIL (eln_load_paths)
  4517         {
  4518           Lisp_Object dir = XCAR (eln_load_paths);
  4519           if (!NILP (Ffile_exists_p (dir)))
  4520             {
  4521               if (!NILP (Ffile_writable_p (dir)))
  4522                 {
  4523                   base_dir = dir;
  4524                   break;
  4525                 }
  4526             }
  4527           else
  4528             {
  4529               /* Try to create the directory and if succeeds use it.  */
  4530               if (NILP (internal_condition_case_1 (make_directory_wrapper,
  4531                                                    dir, Qt,
  4532                                                    make_directory_wrapper_1)))
  4533                 {
  4534                   base_dir = dir;
  4535                   break;
  4536                 }
  4537             }
  4538         }
  4539       if (NILP (base_dir))
  4540         error ("Cannot find suitable directory for output in "
  4541                "`native-comp-eln-load-path'.");
  4542     }
  4543 
  4544   if (!file_name_absolute_p (SSDATA (base_dir)))
  4545     base_dir = Fexpand_file_name (base_dir, Vinvocation_directory);
  4546 
  4547   /* In case the file being compiled is found in 'LISP_PRELOADED' or
  4548      `comp-file-preloaded-p' is non-nil target for output the
  4549      'preloaded' subfolder.  */
  4550   Lisp_Object lisp_preloaded =
  4551     Fgetenv_internal (build_string ("LISP_PRELOADED"), Qnil);
  4552   base_dir = Fexpand_file_name (Vcomp_native_version_dir, base_dir);
  4553   if (comp_file_preloaded_p
  4554       || (!NILP (lisp_preloaded)
  4555           && !NILP (Fmember (CALL1I (file-name-base, source_filename),
  4556                              Fmapcar (intern_c_string ("file-name-base"),
  4557                                       CALL1I (split-string, lisp_preloaded))))))
  4558     base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir);
  4559 
  4560   return Fexpand_file_name (filename, base_dir);
  4561 }
  4562 
  4563 DEFUN ("comp--install-trampoline", Fcomp__install_trampoline,
  4564        Scomp__install_trampoline, 2, 2, 0,
  4565        doc: /* Install a TRAMPOLINE for primitive SUBR-NAME.  */)
  4566   (Lisp_Object subr_name, Lisp_Object trampoline)
  4567 {
  4568   CHECK_SYMBOL (subr_name);
  4569   CHECK_SUBR (trampoline);
  4570   Lisp_Object orig_subr = Fsymbol_function (subr_name);
  4571   CHECK_SUBR (orig_subr);
  4572 
  4573   /* FIXME: add a post dump load trampoline machinery to remove this
  4574      check.  */
  4575   if (will_dump_p ())
  4576     signal_error ("Trying to advice unexpected primitive before dumping",
  4577                   subr_name);
  4578 
  4579   Lisp_Object subr_l = Vcomp_subr_list;
  4580   ptrdiff_t i = ARRAYELTS (helper_link_table);
  4581   FOR_EACH_TAIL (subr_l)
  4582     {
  4583       Lisp_Object subr = XCAR (subr_l);
  4584       if (EQ (subr, orig_subr))
  4585         {
  4586           freloc.link_table[i] = XSUBR (trampoline)->function.a0;
  4587           Fputhash (subr_name, trampoline, Vcomp_installed_trampolines_h);
  4588           return Qt;
  4589         }
  4590       i++;
  4591     }
  4592     signal_error ("Trying to install trampoline for non existent subr",
  4593                   subr_name);
  4594     return Qnil;
  4595 }
  4596 
  4597 DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt,
  4598        0, 0, 0,
  4599        doc: /* Initialize the native compiler context.
  4600 Return t on success.  */)
  4601   (void)
  4602 {
  4603   load_gccjit_if_necessary (true);
  4604 
  4605   if (comp.ctxt)
  4606     {
  4607       xsignal1 (Qnative_ice,
  4608                 build_string ("compiler context already taken"));
  4609       return Qnil;
  4610     }
  4611 
  4612   if (NILP (comp.emitter_dispatcher))
  4613     {
  4614       /* Move this into syms_of_comp the day will be dumpable.  */
  4615       comp.emitter_dispatcher = CALLN (Fmake_hash_table);
  4616       register_emitter (Qset_internal, emit_set_internal);
  4617       register_emitter (Qhelper_unbind_n, emit_simple_limple_call_lisp_ret);
  4618       register_emitter (Qhelper_unwind_protect,
  4619                         emit_simple_limple_call_void_ret);
  4620       register_emitter (Qrecord_unwind_current_buffer,
  4621                         emit_simple_limple_call_lisp_ret);
  4622       register_emitter (Qrecord_unwind_protect_excursion,
  4623                         emit_simple_limple_call_void_ret);
  4624       register_emitter (Qhelper_save_restriction,
  4625                         emit_simple_limple_call_void_ret);
  4626       /* Inliners.  */
  4627       register_emitter (Qadd1, emit_add1);
  4628       register_emitter (Qsub1, emit_sub1);
  4629       register_emitter (Qconsp, emit_consp);
  4630       register_emitter (Qcar, emit_car);
  4631       register_emitter (Qcdr, emit_cdr);
  4632       register_emitter (Qsetcar, emit_setcar);
  4633       register_emitter (Qsetcdr, emit_setcdr);
  4634       register_emitter (Qnegate, emit_negate);
  4635       register_emitter (Qnumberp, emit_numperp);
  4636       register_emitter (Qintegerp, emit_integerp);
  4637       register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit);
  4638     }
  4639 
  4640   comp.ctxt = gcc_jit_context_acquire ();
  4641 
  4642   comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID);
  4643   comp.void_ptr_type =
  4644     gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR);
  4645   comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL);
  4646   comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR);
  4647   comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT);
  4648   comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt,
  4649                                                  GCC_JIT_TYPE_UNSIGNED_INT);
  4650   comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG);
  4651   comp.unsigned_long_type =
  4652     gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG);
  4653   comp.long_long_type =
  4654     gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG);
  4655   comp.unsigned_long_long_type =
  4656     gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG);
  4657   comp.bool_ptr_type = gcc_jit_type_get_pointer (comp.bool_type);
  4658   comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type);
  4659   comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt,
  4660                                                       sizeof (EMACS_INT),
  4661                                                       true);
  4662   comp.emacs_uint_type = gcc_jit_context_get_int_type (comp.ctxt,
  4663                                                        sizeof (EMACS_UINT),
  4664                                                        false);
  4665 #if LISP_WORDS_ARE_POINTERS
  4666   comp.lisp_word_type =
  4667     gcc_jit_type_get_pointer (
  4668       gcc_jit_struct_as_type (
  4669         gcc_jit_context_new_opaque_struct (comp.ctxt,
  4670                                            NULL,
  4671                                            "Lisp_X")));
  4672 #else
  4673   comp.lisp_word_type = comp.emacs_int_type;
  4674 #endif
  4675   comp.lisp_word_tag_type
  4676     = gcc_jit_context_get_int_type (comp.ctxt, sizeof (Lisp_Word_tag), false);
  4677 #ifdef LISP_OBJECT_IS_STRUCT
  4678   comp.lisp_obj_i = gcc_jit_context_new_field (comp.ctxt,
  4679                                                NULL,
  4680                                                comp.lisp_word_type,
  4681                                                "i");
  4682   comp.lisp_obj_s = gcc_jit_context_new_struct_type (comp.ctxt,
  4683                                                      NULL,
  4684                                                      "Lisp_Object",
  4685                                                      1,
  4686                                                      &comp.lisp_obj_i);
  4687   comp.lisp_obj_type = gcc_jit_struct_as_type (comp.lisp_obj_s);
  4688 #else
  4689   comp.lisp_obj_type = comp.lisp_word_type;
  4690 #endif
  4691   comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type);
  4692   comp.zero =
  4693     gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  4694                                          comp.emacs_int_type,
  4695                                          0);
  4696   comp.one =
  4697     gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  4698                                          comp.emacs_int_type,
  4699                                          1);
  4700   comp.inttypebits =
  4701     gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  4702                                          comp.emacs_uint_type,
  4703                                          INTTYPEBITS);
  4704   comp.lisp_int0 =
  4705     gcc_jit_context_new_rvalue_from_int (comp.ctxt,
  4706                                          comp.emacs_int_type,
  4707                                          Lisp_Int0);
  4708   comp.ptrdiff_type = gcc_jit_context_get_int_type (comp.ctxt,
  4709                                                     sizeof (void *),
  4710                                                     true);
  4711   comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt,
  4712                                                     sizeof (void *),
  4713                                                     false);
  4714   comp.size_t_type = gcc_jit_context_get_int_type (comp.ctxt,
  4715                                                    sizeof (size_t),
  4716                                                    false);
  4717 
  4718   comp.exported_funcs_h = CALLN (Fmake_hash_table, QCtest, Qequal);
  4719   /*
  4720     Always reinitialize this cause old function definitions are garbage
  4721     collected by libgccjit when the ctxt is released.
  4722   */
  4723   comp.imported_funcs_h = CALLN (Fmake_hash_table);
  4724 
  4725   define_memcpy ();
  4726 
  4727   /* Define data structures.  */
  4728 
  4729   define_lisp_cons ();
  4730   define_lisp_symbol_with_position ();
  4731   define_jmp_buf ();
  4732   define_handler_struct ();
  4733   define_thread_state_struct ();
  4734 #ifndef LIBGCCJIT_HAVE_gcc_jit_context_new_bitcast
  4735   define_cast_functions ();
  4736 #endif
  4737 
  4738   return Qt;
  4739 }
  4740 
  4741 DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt,
  4742        0, 0, 0,
  4743        doc: /* Release the native compiler context.  */)
  4744   (void)
  4745 {
  4746   load_gccjit_if_necessary (true);
  4747 
  4748   if (comp.ctxt)
  4749     gcc_jit_context_release (comp.ctxt);
  4750 
  4751   if (logfile)
  4752     fclose (logfile);
  4753   comp.ctxt = NULL;
  4754 
  4755   return Qt;
  4756 }
  4757 
  4758 #pragma GCC diagnostic push
  4759 #pragma GCC diagnostic ignored "-Waddress"
  4760 DEFUN ("comp-native-driver-options-effective-p",
  4761        Fcomp_native_driver_options_effective_p,
  4762        Scomp_native_driver_options_effective_p,
  4763        0, 0, 0,
  4764        doc: /* Return t if `comp-native-driver-options' is effective.  */)
  4765   (void)
  4766 {
  4767 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option)
  4768   if (gcc_jit_context_add_driver_option)
  4769     return Qt;
  4770 #endif
  4771   return Qnil;
  4772 }
  4773 #pragma GCC diagnostic pop
  4774 
  4775 #pragma GCC diagnostic push
  4776 #pragma GCC diagnostic ignored "-Waddress"
  4777 DEFUN ("comp-native-compiler-options-effective-p",
  4778        Fcomp_native_compiler_options_effective_p,
  4779        Scomp_native_compiler_options_effective_p,
  4780        0, 0, 0,
  4781        doc: /* Return t if `comp-native-compiler-options' is effective.  */)
  4782   (void)
  4783 {
  4784 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option)
  4785   if (gcc_jit_context_add_command_line_option)
  4786     return Qt;
  4787 #endif
  4788   return Qnil;
  4789 }
  4790 #pragma GCC diagnostic pop
  4791 
  4792 static void
  4793 add_driver_options (void)
  4794 {
  4795   Lisp_Object options = Fsymbol_value (Qnative_comp_driver_options);
  4796 
  4797 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option)
  4798   load_gccjit_if_necessary (true);
  4799   if (!NILP (Fcomp_native_driver_options_effective_p ()))
  4800     FOR_EACH_TAIL (options)
  4801       gcc_jit_context_add_driver_option (comp.ctxt,
  4802                                          /* FIXME: Need to encode
  4803                                             this, but how? either
  4804                                             ENCODE_FILE or
  4805                                             ENCODE_SYSTEM.  */
  4806                                          SSDATA (XCAR (options)));
  4807 #endif
  4808   if (CONSP (options))
  4809     xsignal1 (Qnative_compiler_error,
  4810               build_string ("Customizing native compiler options"
  4811                             " via `comp-native-driver-options' is"
  4812                             " only available on libgccjit version 9"
  4813                             " and above."));
  4814 
  4815   /* Captured `comp-native-driver-options' because file-local.  */
  4816 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option)
  4817   options = comp.driver_options;
  4818   if (!NILP (Fcomp_native_driver_options_effective_p ()))
  4819     FOR_EACH_TAIL (options)
  4820       gcc_jit_context_add_driver_option (comp.ctxt,
  4821                                          /* FIXME: Need to encode
  4822                                             this, but how? either
  4823                                             ENCODE_FILE or
  4824                                             ENCODE_SYSTEM.  */
  4825                                          SSDATA (XCAR (options)));
  4826 #endif
  4827 }
  4828 
  4829 static void
  4830 add_compiler_options (void)
  4831 {
  4832   Lisp_Object options = Fsymbol_value (Qnative_comp_compiler_options);
  4833 
  4834 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option)
  4835   load_gccjit_if_necessary (true);
  4836   if (!NILP (Fcomp_native_compiler_options_effective_p ()))
  4837     FOR_EACH_TAIL (options)
  4838         gcc_jit_context_add_command_line_option (comp.ctxt,
  4839                                                  /* FIXME: Need to encode
  4840                                                     this, but how? either
  4841                                                     ENCODE_FILE or
  4842                                                     ENCODE_SYSTEM.  */
  4843                                                  SSDATA (XCAR (options)));
  4844 #endif
  4845   if (CONSP (options))
  4846     xsignal1 (Qnative_compiler_error,
  4847               build_string ("Customizing native compiler options"
  4848                             " via `comp-native-compiler-options' is"
  4849                             " only available on libgccjit version 9"
  4850                             " and above."));
  4851 
  4852   /* Captured `comp-native-compiler-options' because file-local.  */
  4853 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option)
  4854   options = comp.compiler_options;
  4855   if (!NILP (Fcomp_native_compiler_options_effective_p ()))
  4856     FOR_EACH_TAIL (options)
  4857       gcc_jit_context_add_command_line_option (comp.ctxt,
  4858                                                /* FIXME: Need to encode
  4859                                                   this, but how? either
  4860                                                   ENCODE_FILE or
  4861                                                   ENCODE_SYSTEM.  */
  4862                                                SSDATA (XCAR (options)));
  4863 #endif
  4864 }
  4865 
  4866 DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
  4867        Scomp__compile_ctxt_to_file,
  4868        1, 1, 0,
  4869        doc: /* Compile the current context as native code to file FILENAME.  */)
  4870   (Lisp_Object filename)
  4871 {
  4872   load_gccjit_if_necessary (true);
  4873 
  4874   CHECK_STRING (filename);
  4875   Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4));
  4876   Lisp_Object ebase_name = ENCODE_FILE (base_name);
  4877 
  4878   comp.func_relocs_local = NULL;
  4879 
  4880 #ifdef WINDOWSNT
  4881   ebase_name = ansi_encode_filename (ebase_name);
  4882   /* Tell libgccjit the actual file name of the loaded DLL, otherwise
  4883      it will use 'libgccjit.so', which is not useful.  */
  4884   Lisp_Object libgccjit_loaded_from = Fget (Qgccjit, QCloaded_from);
  4885   Lisp_Object libgccjit_fname;
  4886 
  4887   if (CONSP (libgccjit_loaded_from))
  4888     {
  4889       /* Use the absolute file name if available, otherwise the name
  4890          we looked for in w32_delayed_load.  */
  4891       libgccjit_fname = XCDR (libgccjit_loaded_from);
  4892       if (NILP (libgccjit_fname))
  4893         libgccjit_fname = XCAR (libgccjit_loaded_from);
  4894       /* Must encode to ANSI, as libgccjit will not be able to handle
  4895          UTF-8 encoded file names.  */
  4896       libgccjit_fname = ENCODE_FILE (libgccjit_fname);
  4897       libgccjit_fname = ansi_encode_filename (libgccjit_fname);
  4898       gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME,
  4899                                       SSDATA (libgccjit_fname));
  4900     }
  4901   else  /* this should never happen */
  4902     gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME,
  4903                                     "libgccjit-0.dll");
  4904 #endif
  4905 
  4906   comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt));
  4907   eassert (comp.speed < INT_MAX);
  4908   comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt));
  4909   eassert (comp.debug < INT_MAX);
  4910   comp.driver_options = CALL1I (comp-ctxt-driver-options, Vcomp_ctxt);
  4911   comp.compiler_options = CALL1I (comp-ctxt-compiler-options, Vcomp_ctxt);
  4912 
  4913   if (comp.debug)
  4914       gcc_jit_context_set_bool_option (comp.ctxt,
  4915                                        GCC_JIT_BOOL_OPTION_DEBUGINFO,
  4916                                        1);
  4917   if (comp.debug >= 3)
  4918     {
  4919       logfile = emacs_fopen ("libgccjit.log", "w");
  4920       gcc_jit_context_set_logfile (comp.ctxt,
  4921                                    logfile,
  4922                                    0, 0);
  4923       gcc_jit_context_set_bool_option (comp.ctxt,
  4924                                        GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES,
  4925                                        1);
  4926       gcc_jit_context_set_bool_option (comp.ctxt,
  4927                                        GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING,
  4928                                        1);
  4929     }
  4930 
  4931   gcc_jit_context_set_int_option (comp.ctxt,
  4932                                   GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL,
  4933                                   comp.speed < 0 ? 0
  4934                                   : (comp.speed > 3 ? 3 : comp.speed));
  4935 
  4936   /* On MacOS set a unique dylib ID.  */
  4937 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option)  \
  4938   && defined (DARWIN_OS)
  4939   gcc_jit_context_add_driver_option (comp.ctxt, "-install_name");
  4940   gcc_jit_context_add_driver_option (
  4941          comp.ctxt, SSDATA (Ffile_name_nondirectory (filename)));
  4942 #endif
  4943 
  4944   comp.d_default_idx =
  4945     CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt));
  4946   comp.d_impure_idx =
  4947     CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-impure, Vcomp_ctxt));
  4948   comp.d_ephemeral_idx =
  4949     CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt));
  4950 
  4951   emit_ctxt_code ();
  4952 
  4953   /* Define inline functions.  */
  4954   define_CAR_CDR ();
  4955   define_PSEUDOVECTORP ();
  4956   define_GET_SYMBOL_WITH_POSITION ();
  4957   define_CHECK_TYPE ();
  4958   define_SYMBOL_WITH_POS_SYM ();
  4959   define_CHECK_IMPURE ();
  4960   define_bool_to_lisp_obj ();
  4961   define_setcar_setcdr ();
  4962   define_add1_sub1 ();
  4963   define_negate ();
  4964   define_maybe_gc_or_quit ();
  4965 
  4966   struct Lisp_Hash_Table *func_h =
  4967     XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt));
  4968   for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++)
  4969     if (!BASE_EQ (HASH_VALUE (func_h, i), Qunbound))
  4970       declare_function (HASH_VALUE (func_h, i));
  4971   /* Compile all functions. Can't be done before because the
  4972      relocation structs has to be already defined.  */
  4973   for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++)
  4974     if (!BASE_EQ (HASH_VALUE (func_h, i), Qunbound))
  4975       compile_function (HASH_VALUE (func_h, i));
  4976 
  4977   /* Work around bug#46495 (GCC PR99126). */
  4978 #if defined (WIDE_EMACS_INT)                                            \
  4979   && defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option)
  4980   Lisp_Object version = Fcomp_libgccjit_version ();
  4981   if (NILP (version)
  4982       || XFIXNUM (XCAR (version)) < 11)
  4983     gcc_jit_context_add_command_line_option (comp.ctxt,
  4984                                              "-fdisable-tree-isolate-paths");
  4985 #endif
  4986 
  4987   add_compiler_options ();
  4988   add_driver_options ();
  4989 
  4990   if (comp.debug > 1)
  4991       gcc_jit_context_dump_to_file (comp.ctxt,
  4992                                     format_string ("%s.c", SSDATA (ebase_name)),
  4993                                     1);
  4994   if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer)))
  4995     gcc_jit_context_dump_reproducer_to_file (
  4996       comp.ctxt,
  4997       format_string ("%s_libgccjit_repro.c", SSDATA (ebase_name)));
  4998 
  4999   Lisp_Object tmp_file =
  5000     CALL4I (make-temp-file, base_name, Qnil, build_string (".eln.tmp"), Qnil);
  5001 
  5002   Lisp_Object encoded_tmp_file = ENCODE_FILE (tmp_file);
  5003 #ifdef WINDOWSNT
  5004   encoded_tmp_file = ansi_encode_filename (encoded_tmp_file);
  5005 #endif
  5006   gcc_jit_context_compile_to_file (comp.ctxt,
  5007                                    GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY,
  5008                                    SSDATA (encoded_tmp_file));
  5009 
  5010   const char *err =  gcc_jit_context_get_first_error (comp.ctxt);
  5011   if (err)
  5012     xsignal3 (Qnative_ice,
  5013               build_string ("failed to compile"),
  5014               filename,
  5015               build_string (err));
  5016 
  5017   CALL1I (comp-clean-up-stale-eln, filename);
  5018   CALL2I (comp-delete-or-replace-file, filename, tmp_file);
  5019 
  5020   return filename;
  5021 }
  5022 
  5023 #pragma GCC diagnostic push
  5024 #pragma GCC diagnostic ignored "-Waddress"
  5025 DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version,
  5026        Scomp_libgccjit_version, 0, 0, 0,
  5027        doc: /* Return libgccjit version in use.
  5028 
  5029 The return value has the form (MAJOR MINOR PATCHLEVEL) or nil if
  5030 unknown (before GCC version 10).  */)
  5031   (void)
  5032 {
  5033 #if defined (LIBGCCJIT_HAVE_gcc_jit_version)
  5034   load_gccjit_if_necessary (true);
  5035 
  5036   return gcc_jit_version_major
  5037     ? list3 (make_fixnum (gcc_jit_version_major ()),
  5038              make_fixnum (gcc_jit_version_minor ()),
  5039              make_fixnum (gcc_jit_version_patchlevel ()))
  5040     : Qnil;
  5041 #else
  5042   return Qnil;
  5043 #endif
  5044 }
  5045 #pragma GCC diagnostic pop
  5046 
  5047 
  5048 /******************************************************************************/
  5049 /* Helper functions called from the run-time.                                 */
  5050 /* Note: this are all potentially definable directly to gcc and are here just */
  5051 /* for laziness. Change this if a performance impact is measured.             */
  5052 /******************************************************************************/
  5053 
  5054 static void
  5055 helper_unwind_protect (Lisp_Object handler)
  5056 {
  5057   /* Support for a function here is new in 24.4.  */
  5058   record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore,
  5059                          handler);
  5060 }
  5061 
  5062 static Lisp_Object
  5063 helper_unbind_n (Lisp_Object n)
  5064 {
  5065   return unbind_to (specpdl_ref_add (SPECPDL_INDEX (), -XFIXNUM (n)), Qnil);
  5066 }
  5067 
  5068 static void
  5069 helper_save_restriction (void)
  5070 {
  5071   record_unwind_protect (save_restriction_restore,
  5072                          save_restriction_save ());
  5073 }
  5074 
  5075 static bool
  5076 helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code)
  5077 {
  5078   return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike,
  5079                                      union vectorlike_header),
  5080                              code);
  5081 }
  5082 
  5083 static struct Lisp_Symbol_With_Pos *
  5084 helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a)
  5085 {
  5086   if (!SYMBOL_WITH_POS_P (a))
  5087     wrong_type_argument (Qwrong_type_argument, a);
  5088   return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
  5089 }
  5090 
  5091 
  5092 /* `native-comp-eln-load-path' clean-up support code.  */
  5093 
  5094 #ifdef WINDOWSNT
  5095 static Lisp_Object
  5096 return_nil (Lisp_Object arg)
  5097 {
  5098   return Qnil;
  5099 }
  5100 
  5101 static Lisp_Object
  5102 directory_files_matching (Lisp_Object name, Lisp_Object match)
  5103 {
  5104   return Fdirectory_files (name, Qt, match, Qnil, Qnil);
  5105 }
  5106 #endif
  5107 
  5108 /* Windows does not let us delete a .eln file that is currently loaded
  5109    by a process.  The strategy is to rename .eln files into .old.eln
  5110    instead of removing them when this is not possible and clean-up
  5111    `native-comp-eln-load-path' when exiting.
  5112 
  5113    Any error is ignored because it may be due to the file being loaded
  5114    in another Emacs instance.  */
  5115 void
  5116 eln_load_path_final_clean_up (void)
  5117 {
  5118 #ifdef WINDOWSNT
  5119   Lisp_Object dir_tail = Vnative_comp_eln_load_path;
  5120   FOR_EACH_TAIL (dir_tail)
  5121     {
  5122       Lisp_Object files_in_dir =
  5123         internal_condition_case_2 (directory_files_matching,
  5124                                    Fexpand_file_name (Vcomp_native_version_dir,
  5125                                                       XCAR (dir_tail)),
  5126                                    build_string ("\\.eln\\.old\\'"),
  5127                                    Qt, return_nil);
  5128       FOR_EACH_TAIL (files_in_dir)
  5129         internal_delete_file (XCAR (files_in_dir));
  5130     }
  5131 #endif
  5132 }
  5133 
  5134 /* This function puts the compilation unit in the
  5135   `Vcomp_loaded_comp_units_h` hashmap.  */
  5136 static void
  5137 register_native_comp_unit (Lisp_Object comp_u)
  5138 {
  5139   Fputhash (
  5140     XNATIVE_COMP_UNIT (comp_u)->file, comp_u, Vcomp_loaded_comp_units_h);
  5141 }
  5142 
  5143 
  5144 /***********************************/
  5145 /* Deferred compilation mechanism. */
  5146 /***********************************/
  5147 
  5148 /* Queue an asynchronous compilation for the source file defining
  5149    FUNCTION_NAME and perform a late load.
  5150 
  5151    NOTE: ideally would be nice to move its call simply into Fload but
  5152    we need DEFINITION to guard against function redefinition while
  5153    async compilation happen.  */
  5154 
  5155 void
  5156 maybe_defer_native_compilation (Lisp_Object function_name,
  5157                                 Lisp_Object definition)
  5158 {
  5159 #if 0
  5160 #include <sys/types.h>
  5161 #include <unistd.h>
  5162   if (!NILP (function_name) &&
  5163       STRINGP (Vload_true_file_name))
  5164     {
  5165       static FILE *f;
  5166       if (!f)
  5167         {
  5168           char str[128];
  5169           sprintf (str, "log_%d", getpid ());
  5170           f = fopen (str, "w");
  5171         }
  5172       if (!f)
  5173         exit (1);
  5174       fprintf (f, "function %s file %s\n",
  5175                SSDATA (Fsymbol_name (function_name)),
  5176                SSDATA (Vload_true_file_name));
  5177       fflush (f);
  5178     }
  5179 #endif
  5180   if (!load_gccjit_if_necessary (false))
  5181     return;
  5182 
  5183   if (!native_comp_jit_compilation
  5184       || noninteractive
  5185       || !NILP (Vpurify_flag)
  5186       || !COMPILEDP (definition)
  5187       || !STRINGP (Vload_true_file_name)
  5188       || !suffix_p (Vload_true_file_name, ".elc")
  5189       || !NILP (Fgethash (Vload_true_file_name, V_comp_no_native_file_h, Qnil)))
  5190     return;
  5191 
  5192   Lisp_Object src =
  5193     concat2 (CALL1I (file-name-sans-extension, Vload_true_file_name),
  5194              build_pure_c_string (".el"));
  5195   if (NILP (Ffile_exists_p (src)))
  5196     {
  5197       src = concat2 (src, build_pure_c_string (".gz"));
  5198       if (NILP (Ffile_exists_p (src)))
  5199         return;
  5200     }
  5201 
  5202   Fputhash (function_name, definition, Vcomp_deferred_pending_h);
  5203 
  5204   pending_funcalls
  5205     = Fcons (list (Qnative__compile_async, src, Qnil, Qlate),
  5206              pending_funcalls);
  5207 }
  5208 
  5209 
  5210 /**************************************/
  5211 /* Functions used to load eln files.  */
  5212 /**************************************/
  5213 
  5214 /* Fixup the system eln-cache directory, which is the last entry in
  5215    `native-comp-eln-load-path'.  Argument is a .eln file in that directory.  */
  5216 void
  5217 fixup_eln_load_path (Lisp_Object eln_filename)
  5218 {
  5219   Lisp_Object last_cell = Qnil;
  5220   Lisp_Object tem = Vnative_comp_eln_load_path;
  5221   FOR_EACH_TAIL (tem)
  5222     if (CONSP (tem))
  5223       last_cell = tem;
  5224 
  5225   const char preloaded[] = "/preloaded/";
  5226   Lisp_Object eln_cache_sys = Ffile_name_directory (eln_filename);
  5227   const char *p_preloaded =
  5228     SSDATA (eln_cache_sys) + SBYTES (eln_cache_sys) - sizeof (preloaded) + 1;
  5229   bool preloaded_p = strcmp (p_preloaded, preloaded) == 0;
  5230 
  5231   /* One or two directories up...  */
  5232   for (int i = 0; i < (preloaded_p ? 2 : 1); i++)
  5233     eln_cache_sys =
  5234       Ffile_name_directory (Fsubstring_no_properties (eln_cache_sys, Qnil,
  5235                                                       make_fixnum (-1)));
  5236   Fsetcar (last_cell, eln_cache_sys);
  5237 }
  5238 
  5239 typedef char *(*comp_lit_str_func) (void);
  5240 
  5241 /* Deserialize read and return static object.  */
  5242 static Lisp_Object
  5243 load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name)
  5244 {
  5245   static_obj_t *blob =
  5246     dynlib_sym (comp_u->handle, format_string ("%s_blob", name));
  5247   if (blob)
  5248     /* New blob format.  */
  5249     return Fread (make_string (blob->data, blob->len));
  5250 
  5251   static_obj_t *(*f)(void) = dynlib_sym (comp_u->handle, name);
  5252   if (!f)
  5253     xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
  5254 
  5255   blob = f ();
  5256   return Fread (make_string (blob->data, blob->len));
  5257 
  5258 }
  5259 
  5260 /* Return false when something is wrong or true otherwise.  */
  5261 
  5262 static bool
  5263 check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u)
  5264 {
  5265   dynlib_handle_ptr handle = comp_u->handle;
  5266   Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
  5267   Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM);
  5268 
  5269   EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec));
  5270   for (ptrdiff_t i = 0; i < d_vec_len; i++)
  5271     if (!EQ (data_relocs[i],  AREF (comp_u->data_vec, i)))
  5272       return false;
  5273 
  5274   d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec));
  5275   for (ptrdiff_t i = 0; i < d_vec_len; i++)
  5276     {
  5277       Lisp_Object x = data_imp_relocs[i];
  5278       if (EQ (x, Qlambda_fixup))
  5279         return false;
  5280       else if (SUBR_NATIVE_COMPILEDP (x))
  5281         {
  5282           if (NILP (Fgethash (x, comp_u->lambda_gc_guard_h, Qnil)))
  5283             return false;
  5284         }
  5285       else if (!EQ (data_imp_relocs[i], AREF (comp_u->data_impure_vec, i)))
  5286         return false;
  5287     }
  5288   return true;
  5289 }
  5290 
  5291 static void
  5292 unset_cu_load_ongoing (Lisp_Object comp_u)
  5293 {
  5294   XNATIVE_COMP_UNIT (comp_u)->load_ongoing = false;
  5295 }
  5296 
  5297 Lisp_Object
  5298 load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump,
  5299                 bool late_load)
  5300 {
  5301   Lisp_Object res = Qnil;
  5302   dynlib_handle_ptr handle = comp_u->handle;
  5303   Lisp_Object comp_u_lisp_obj;
  5304   XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u);
  5305 
  5306   Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM);
  5307   if (!saved_cu)
  5308     xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
  5309   comp_u->loaded_once = !NILP (*saved_cu);
  5310   Lisp_Object *data_eph_relocs =
  5311     dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM);
  5312 
  5313   /* While resurrecting from an image dump loading more than once the
  5314      same compilation unit does not make any sense.  */
  5315   eassert (!(loading_dump && comp_u->loaded_once));
  5316 
  5317   if (comp_u->loaded_once)
  5318     /* 'dlopen' returns the same handle when trying to load two times
  5319        the same shared.  In this case touching 'd_reloc' etc leads to
  5320        fails in case a frame with a reference to it in a live reg is
  5321        active (native-comp-speed > 0).
  5322 
  5323        We must *never* mess with static pointers in an already loaded
  5324        eln.  */
  5325     {
  5326       comp_u_lisp_obj = *saved_cu;
  5327       comp_u = XNATIVE_COMP_UNIT (comp_u_lisp_obj);
  5328       comp_u->loaded_once = true;
  5329     }
  5330   else
  5331     *saved_cu = comp_u_lisp_obj;
  5332 
  5333   /* Once we are sure to have the right compilation unit we want to
  5334      identify is we have at least another load active on it.  */
  5335   bool recursive_load = comp_u->load_ongoing;
  5336   comp_u->load_ongoing = true;
  5337   specpdl_ref count = SPECPDL_INDEX ();
  5338   if (!recursive_load)
  5339     record_unwind_protect (unset_cu_load_ongoing, comp_u_lisp_obj);
  5340 
  5341   freloc_check_fill ();
  5342 
  5343   Lisp_Object (*top_level_run)(Lisp_Object)
  5344     = dynlib_sym (handle,
  5345                   late_load ? "late_top_level_run" : "top_level_run");
  5346 
  5347   /* Always set data_imp_relocs pointer in the compilation unit (in can be
  5348      used in 'dump_do_dump_relocation').  */
  5349   comp_u->data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM);
  5350 
  5351   if (!comp_u->loaded_once)
  5352     {
  5353       struct thread_state ***current_thread_reloc =
  5354         dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM);
  5355       bool **f_symbols_with_pos_enabled_reloc =
  5356         dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM);
  5357       void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM);
  5358       Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
  5359       Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs;
  5360       void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
  5361 
  5362       if (!(current_thread_reloc
  5363             && f_symbols_with_pos_enabled_reloc
  5364             && pure_reloc
  5365             && data_relocs
  5366             && data_imp_relocs
  5367             && data_eph_relocs
  5368             && freloc_link_table
  5369             && top_level_run)
  5370           || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM),
  5371                                   Vcomp_abi_hash)))
  5372         xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
  5373 
  5374       *current_thread_reloc = &current_thread;
  5375       *f_symbols_with_pos_enabled_reloc = &symbols_with_pos_enabled;
  5376       *pure_reloc = pure;
  5377 
  5378       /* Imported functions.  */
  5379       *freloc_link_table = freloc.link_table;
  5380 
  5381       /* Imported data.  */
  5382       if (!loading_dump)
  5383         {
  5384           comp_u->optimize_qualities =
  5385             load_static_obj (comp_u, TEXT_OPTIM_QLY_SYM);
  5386           comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM);
  5387           comp_u->data_impure_vec =
  5388             load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM);
  5389 
  5390           if (!NILP (Vpurify_flag))
  5391             /* Non impure can be copied into pure space.  */
  5392             comp_u->data_vec = Fpurecopy (comp_u->data_vec);
  5393         }
  5394 
  5395       EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec));
  5396       for (EMACS_INT i = 0; i < d_vec_len; i++)
  5397         data_relocs[i] = AREF (comp_u->data_vec, i);
  5398 
  5399       d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec));
  5400       for (EMACS_INT i = 0; i < d_vec_len; i++)
  5401         data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i);
  5402     }
  5403 
  5404   if (!loading_dump)
  5405     {
  5406       /* Note: data_ephemeral_vec is not GC protected except than by
  5407          this function frame.  After this functions will be
  5408          deactivated GC will be free to collect it, but it MUST
  5409          survive till 'top_level_run' has finished his job.  We store
  5410          into the ephemeral allocation class only objects that we know
  5411          are necessary exclusively during the first load.  Once these
  5412          are collected we don't have to maintain them in the heap
  5413          forever.  */
  5414       Lisp_Object volatile data_ephemeral_vec = Qnil;
  5415       /* In case another load of the same CU is active on the stack
  5416          all ephemeral data is hold by that frame.  Re-writing
  5417          'data_ephemeral_vec' would be not only a waste of cycles but
  5418          more importantly would lead to crashes if the contained data
  5419          is not cons hashed.  */
  5420       if (!recursive_load)
  5421         {
  5422           data_ephemeral_vec =
  5423             load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM);
  5424 
  5425           EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec));
  5426           for (EMACS_INT i = 0; i < d_vec_len; i++)
  5427             data_eph_relocs[i] = AREF (data_ephemeral_vec, i);
  5428         }
  5429       /* Executing this will perform all the expected environment
  5430          modifications.  */
  5431       res = top_level_run (comp_u_lisp_obj);
  5432       /* Make sure data_ephemeral_vec still exists after top_level_run has run.
  5433          Guard against sibling call optimization (or any other).  */
  5434       data_ephemeral_vec = data_ephemeral_vec;
  5435       eassert (check_comp_unit_relocs (comp_u));
  5436     }
  5437 
  5438   if (!recursive_load)
  5439     /* Clean-up the load ongoing flag in case.  */
  5440     unbind_to (count, Qnil);
  5441 
  5442   register_native_comp_unit (comp_u_lisp_obj);
  5443 
  5444   return res;
  5445 }
  5446 
  5447 void
  5448 unload_comp_unit (struct Lisp_Native_Comp_Unit *cu)
  5449 {
  5450   if (cu->handle == NULL)
  5451     return;
  5452 
  5453   Lisp_Object *saved_cu = dynlib_sym (cu->handle, COMP_UNIT_SYM);
  5454   Lisp_Object this_cu;
  5455   XSETNATIVE_COMP_UNIT (this_cu, cu);
  5456   if (EQ (this_cu, *saved_cu))
  5457     *saved_cu = Qnil;
  5458   dynlib_close (cu->handle);
  5459 }
  5460 
  5461 Lisp_Object
  5462 native_function_doc (Lisp_Object function)
  5463 {
  5464   struct Lisp_Native_Comp_Unit *cu =
  5465     XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function));
  5466 
  5467   if (NILP (cu->data_fdoc_v))
  5468     cu->data_fdoc_v = load_static_obj (cu, TEXT_FDOC_SYM);
  5469   if (!VECTORP (cu->data_fdoc_v))
  5470     xsignal2 (Qnative_lisp_file_inconsistent, cu->file,
  5471               build_string ("missing documentation vector"));
  5472   return AREF (cu->data_fdoc_v, XSUBR (function)->doc);
  5473 }
  5474 
  5475 static Lisp_Object
  5476 make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg,
  5477            Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx,
  5478            Lisp_Object intspec, Lisp_Object command_modes, Lisp_Object comp_u)
  5479 {
  5480   struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
  5481   dynlib_handle_ptr handle = cu->handle;
  5482   if (!handle)
  5483     xsignal0 (Qwrong_register_subr_call);
  5484 
  5485   void *func = dynlib_sym (handle, SSDATA (c_name));
  5486   eassert (func);
  5487   union Aligned_Lisp_Subr *x =
  5488     (union Aligned_Lisp_Subr *) allocate_pseudovector (
  5489                                   VECSIZE (union Aligned_Lisp_Subr),
  5490                                   0, VECSIZE (union Aligned_Lisp_Subr),
  5491                                   PVEC_SUBR);
  5492   if (CONSP (minarg))
  5493     {
  5494       /* Dynamic code.  */
  5495 #ifdef HAVE_NATIVE_COMP
  5496       x->s.lambda_list = maxarg;
  5497 #endif
  5498       maxarg = XCDR (minarg);
  5499       minarg = XCAR (minarg);
  5500     }
  5501   else
  5502     {
  5503 #ifdef HAVE_NATIVE_COMP
  5504       x->s.lambda_list = Qnil;
  5505 #endif
  5506     }
  5507   x->s.function.a0 = func;
  5508   x->s.min_args = XFIXNUM (minarg);
  5509   x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY;
  5510   x->s.symbol_name = xstrdup (SSDATA (symbol_name));
  5511   x->s.intspec.native = intspec;
  5512   x->s.command_modes = command_modes;
  5513   x->s.doc = XFIXNUM (doc_idx);
  5514 #ifdef HAVE_NATIVE_COMP
  5515   x->s.native_comp_u = comp_u;
  5516   x->s.native_c_name = xstrdup (SSDATA (c_name));
  5517   x->s.type = type;
  5518 #endif
  5519   Lisp_Object tem;
  5520   XSETSUBR (tem, &x->s);
  5521 
  5522   return tem;
  5523 }
  5524 
  5525 DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda,
  5526        7, 7, 0,
  5527        doc: /* Register anonymous lambda.
  5528 This gets called by top_level_run during the load phase.  */)
  5529   (Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg,
  5530    Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
  5531    Lisp_Object comp_u)
  5532 {
  5533   Lisp_Object doc_idx = FIRST (rest);
  5534   Lisp_Object intspec = SECOND (rest);
  5535   Lisp_Object command_modes = THIRD (rest);
  5536 
  5537   struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
  5538   if (cu->loaded_once)
  5539     return Qnil;
  5540 
  5541   Lisp_Object tem =
  5542     make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec,
  5543                command_modes, comp_u);
  5544 
  5545   /* We must protect it against GC because the function is not
  5546      reachable through symbols.  */
  5547   Fputhash (tem, Qt, cu->lambda_gc_guard_h);
  5548   /* This is for fixing up the value in d_reloc while resurrecting
  5549      from dump.  See 'dump_do_dump_relocation'.  */
  5550   eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil)));
  5551   Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h);
  5552   /* Do the real relocation fixup.  */
  5553   cu->data_imp_relocs[XFIXNUM (reloc_idx)] = tem;
  5554 
  5555   return tem;
  5556 }
  5557 
  5558 DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr,
  5559        7, 7, 0,
  5560        doc: /* Register exported subr.
  5561 This gets called by top_level_run during the load phase.  */)
  5562   (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg,
  5563    Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
  5564    Lisp_Object comp_u)
  5565 {
  5566   Lisp_Object doc_idx = FIRST (rest);
  5567   Lisp_Object intspec = SECOND (rest);
  5568   Lisp_Object command_modes = THIRD (rest);
  5569 
  5570   Lisp_Object tem =
  5571     make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx,
  5572                intspec, command_modes, comp_u);
  5573 
  5574   defalias (name, tem);
  5575 
  5576   return tem;
  5577 }
  5578 
  5579 DEFUN ("comp--late-register-subr", Fcomp__late_register_subr,
  5580        Scomp__late_register_subr, 7, 7, 0,
  5581        doc: /* Register exported subr.
  5582 This gets called by late_top_level_run during the load phase.  */)
  5583   (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg,
  5584    Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
  5585    Lisp_Object comp_u)
  5586 {
  5587   if (!NILP (Fequal (Fsymbol_function (name),
  5588                      Fgethash (name, Vcomp_deferred_pending_h, Qnil))))
  5589     Fcomp__register_subr (name, c_name, minarg, maxarg, type, rest, comp_u);
  5590   Fremhash (name, Vcomp_deferred_pending_h);
  5591   return Qnil;
  5592 }
  5593 
  5594 static bool
  5595 file_in_eln_sys_dir (Lisp_Object filename)
  5596 {
  5597   Lisp_Object eln_sys_dir = Qnil;
  5598   Lisp_Object tmp = Vnative_comp_eln_load_path;
  5599   FOR_EACH_TAIL (tmp)
  5600     eln_sys_dir = XCAR (tmp);
  5601   return !NILP (Fstring_match (Fregexp_quote (Fexpand_file_name (eln_sys_dir,
  5602                                                                  Qnil)),
  5603                                Fexpand_file_name (filename, Qnil),
  5604                                Qnil, Qnil));
  5605 }
  5606 
  5607 /* Load related routines.  */
  5608 DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0,
  5609        doc: /* Load native elisp code FILENAME.
  5610 LATE-LOAD has to be non-nil when loading for deferred compilation.  */)
  5611   (Lisp_Object filename, Lisp_Object late_load)
  5612 {
  5613   CHECK_STRING (filename);
  5614   if (NILP (Ffile_exists_p (filename)))
  5615     xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"),
  5616               filename);
  5617   struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit ();
  5618   Lisp_Object encoded_filename = ENCODE_FILE (filename);
  5619 
  5620   if (!NILP (Fgethash (filename, Vcomp_loaded_comp_units_h, Qnil))
  5621       && !file_in_eln_sys_dir (filename)
  5622       && !NILP (Ffile_writable_p (filename)))
  5623     {
  5624       /* If in this session there was ever a file loaded with this
  5625          name, rename it before loading, to make sure we always get a
  5626          new handle!  */
  5627       Lisp_Object tmp_filename =
  5628         Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"),
  5629                                   Qnil);
  5630       if (NILP (Ffile_writable_p (tmp_filename)))
  5631         comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename));
  5632       else
  5633         {
  5634           Frename_file (filename, tmp_filename, Qt);
  5635           comp_u->handle = dynlib_open_for_eln (SSDATA (ENCODE_FILE (tmp_filename)));
  5636           Frename_file (tmp_filename, filename, Qnil);
  5637         }
  5638     }
  5639   else
  5640     comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename));
  5641 
  5642   if (!comp_u->handle)
  5643     xsignal2 (Qnative_lisp_load_failed, filename,
  5644               build_string (dynlib_error ()));
  5645   comp_u->file = filename;
  5646   comp_u->data_vec = Qnil;
  5647   comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq);
  5648   comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal);
  5649   return load_comp_unit (comp_u, false, !NILP (late_load));
  5650 }
  5651 
  5652 #endif /* HAVE_NATIVE_COMP */
  5653 
  5654 DEFUN ("native-comp-available-p", Fnative_comp_available_p,
  5655        Snative_comp_available_p, 0, 0, 0,
  5656        doc: /* Return non-nil if native compilation support is built-in.  */)
  5657   (void)
  5658 {
  5659 #ifdef HAVE_NATIVE_COMP
  5660   return load_gccjit_if_necessary (false) ? Qt : Qnil;
  5661 #else
  5662   return Qnil;
  5663 #endif
  5664 }
  5665 
  5666 
  5667 void
  5668 syms_of_comp (void)
  5669 {
  5670 #ifdef HAVE_NATIVE_COMP
  5671   DEFVAR_BOOL ("native-comp-jit-compilation", native_comp_jit_compilation,
  5672     doc: /* If non-nil, compile loaded .elc files asynchronously.
  5673 
  5674 After compilation, each function definition is updated to use the
  5675 natively-compiled one.  */);
  5676   native_comp_jit_compilation = true;
  5677 
  5678   DEFSYM (Qnative_comp_speed, "native-comp-speed");
  5679   DEFSYM (Qnative_comp_debug, "native-comp-debug");
  5680   DEFSYM (Qnative_comp_driver_options, "native-comp-driver-options");
  5681   DEFSYM (Qnative_comp_compiler_options, "native-comp-compiler-options");
  5682   DEFSYM (Qcomp_libgccjit_reproducer, "comp-libgccjit-reproducer");
  5683 
  5684   /* Limple instruction set.  */
  5685   DEFSYM (Qcomment, "comment");
  5686   DEFSYM (Qjump, "jump");
  5687   DEFSYM (Qcall, "call");
  5688   DEFSYM (Qcallref, "callref");
  5689   DEFSYM (Qdirect_call, "direct-call");
  5690   DEFSYM (Qdirect_callref, "direct-callref");
  5691   DEFSYM (Qassume, "assume");
  5692   DEFSYM (Qsetimm, "setimm");
  5693   DEFSYM (Qreturn, "return");
  5694   DEFSYM (Qunreachable, "unreachable");
  5695   DEFSYM (Qcomp_mvar, "comp-mvar");
  5696   DEFSYM (Qcond_jump, "cond-jump");
  5697   DEFSYM (Qphi, "phi");
  5698   /* Ops in use for prologue emission.  */
  5699   DEFSYM (Qset_par_to_local, "set-par-to-local");
  5700   DEFSYM (Qset_args_to_local, "set-args-to-local");
  5701   DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local");
  5702   DEFSYM (Qinc_args, "inc-args");
  5703   DEFSYM (Qcond_jump_narg_leq, "cond-jump-narg-leq");
  5704   /* Others.  */
  5705   DEFSYM (Qpush_handler, "push-handler");
  5706   DEFSYM (Qpop_handler, "pop-handler");
  5707   DEFSYM (Qfetch_handler, "fetch-handler");
  5708   DEFSYM (Qcondition_case, "condition-case");
  5709   /* call operands.  */
  5710   DEFSYM (Qcatcher, "catcher");
  5711   DEFSYM (Qentry, "entry");
  5712   DEFSYM (Qset_internal, "set_internal");
  5713   DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer");
  5714   DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion");
  5715   DEFSYM (Qhelper_unbind_n, "helper_unbind_n");
  5716   DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect");
  5717   DEFSYM (Qhelper_save_restriction, "helper_save_restriction");
  5718   /* Inliners.  */
  5719   DEFSYM (Qadd1, "1+");
  5720   DEFSYM (Qsub1, "1-");
  5721   DEFSYM (Qconsp, "consp");
  5722   DEFSYM (Qcar, "car");
  5723   DEFSYM (Qcdr, "cdr");
  5724   DEFSYM (Qsetcar, "setcar");
  5725   DEFSYM (Qsetcdr, "setcdr");
  5726   DEFSYM (Qnegate, "negate");
  5727   DEFSYM (Qnumberp, "numberp");
  5728   DEFSYM (Qintegerp, "integerp");
  5729   DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit");
  5730   DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
  5731 
  5732   /* Allocation classes. */
  5733   DEFSYM (Qd_default, "d-default");
  5734   DEFSYM (Qd_impure, "d-impure");
  5735   DEFSYM (Qd_ephemeral, "d-ephemeral");
  5736 
  5737   /* Others.  */
  5738   DEFSYM (Qcomp, "comp");
  5739   DEFSYM (Qfixnum, "fixnum");
  5740   DEFSYM (Qscratch, "scratch");
  5741   DEFSYM (Qlate, "late");
  5742   DEFSYM (Qlambda_fixup, "lambda-fixup");
  5743   DEFSYM (Qgccjit, "gccjit");
  5744   DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install");
  5745   DEFSYM (Qnative_comp_warning_on_missing_source,
  5746           "native-comp-warning-on-missing-source");
  5747 
  5748   /* To be signaled by the compiler.  */
  5749   DEFSYM (Qnative_compiler_error, "native-compiler-error");
  5750   Fput (Qnative_compiler_error, Qerror_conditions,
  5751         pure_list (Qnative_compiler_error, Qerror));
  5752   Fput (Qnative_compiler_error, Qerror_message,
  5753         build_pure_c_string ("Native compiler error"));
  5754 
  5755   DEFSYM (Qnative_ice, "native-ice");
  5756   Fput (Qnative_ice, Qerror_conditions,
  5757         pure_list (Qnative_ice, Qnative_compiler_error, Qerror));
  5758   Fput (Qnative_ice, Qerror_message,
  5759         build_pure_c_string ("Internal native compiler error"));
  5760 
  5761   /* By the load machinery.  */
  5762   DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed");
  5763   Fput (Qnative_lisp_load_failed, Qerror_conditions,
  5764         pure_list (Qnative_lisp_load_failed, Qerror));
  5765   Fput (Qnative_lisp_load_failed, Qerror_message,
  5766         build_pure_c_string ("Native elisp load failed"));
  5767 
  5768   DEFSYM (Qnative_lisp_wrong_reloc, "native-lisp-wrong-reloc");
  5769   Fput (Qnative_lisp_wrong_reloc, Qerror_conditions,
  5770         pure_list (Qnative_lisp_wrong_reloc, Qnative_lisp_load_failed, Qerror));
  5771   Fput (Qnative_lisp_wrong_reloc, Qerror_message,
  5772         build_pure_c_string ("Primitive redefined or wrong relocation"));
  5773 
  5774   DEFSYM (Qwrong_register_subr_call, "wrong-register-subr-call");
  5775   Fput (Qwrong_register_subr_call, Qerror_conditions,
  5776         pure_list (Qwrong_register_subr_call, Qnative_lisp_load_failed, Qerror));
  5777   Fput (Qwrong_register_subr_call, Qerror_message,
  5778         build_pure_c_string ("comp--register-subr can only be called during "
  5779                             "native lisp load phase."));
  5780 
  5781   DEFSYM (Qnative_lisp_file_inconsistent, "native-lisp-file-inconsistent");
  5782   Fput (Qnative_lisp_file_inconsistent, Qerror_conditions,
  5783         pure_list (Qnative_lisp_file_inconsistent, Qnative_lisp_load_failed, Qerror));
  5784   Fput (Qnative_lisp_file_inconsistent, Qerror_message,
  5785         build_pure_c_string ("eln file inconsistent with current runtime "
  5786                              "configuration, please recompile"));
  5787 
  5788   DEFSYM (Qnative__compile_async, "native--compile-async");
  5789 
  5790   defsubr (&Scomp__subr_signature);
  5791   defsubr (&Scomp_el_to_eln_rel_filename);
  5792   defsubr (&Scomp_el_to_eln_filename);
  5793   defsubr (&Scomp_native_driver_options_effective_p);
  5794   defsubr (&Scomp_native_compiler_options_effective_p);
  5795   defsubr (&Scomp__install_trampoline);
  5796   defsubr (&Scomp__init_ctxt);
  5797   defsubr (&Scomp__release_ctxt);
  5798   defsubr (&Scomp__compile_ctxt_to_file);
  5799   defsubr (&Scomp_libgccjit_version);
  5800   defsubr (&Scomp__register_lambda);
  5801   defsubr (&Scomp__register_subr);
  5802   defsubr (&Scomp__late_register_subr);
  5803   defsubr (&Snative_elisp_load);
  5804 
  5805   staticpro (&comp.exported_funcs_h);
  5806   comp.exported_funcs_h = Qnil;
  5807   staticpro (&comp.imported_funcs_h);
  5808   comp.imported_funcs_h = Qnil;
  5809   staticpro (&comp.func_blocks_h);
  5810   staticpro (&comp.emitter_dispatcher);
  5811   comp.emitter_dispatcher = Qnil;
  5812   staticpro (&loadsearch_re_list);
  5813   loadsearch_re_list = Qnil;
  5814 
  5815   DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt,
  5816                doc: /* The compiler context.  */);
  5817   Vcomp_ctxt = Qnil;
  5818 
  5819   /* FIXME should be initialized but not here...  Plus this don't have
  5820      to be necessarily exposed to lisp but can easy debug for now.  */
  5821   DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list,
  5822     doc: /* List of all defined subrs.  */);
  5823   DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash,
  5824     doc: /* String signing the .eln files ABI.  */);
  5825   Vcomp_abi_hash = Qnil;
  5826   DEFVAR_LISP ("comp-native-version-dir", Vcomp_native_version_dir,
  5827     doc: /* Directory in use to disambiguate eln compatibility.  */);
  5828   Vcomp_native_version_dir = Qnil;
  5829 
  5830   DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h,
  5831     doc: /* Hash table symbol-name -> function-value.
  5832 For internal use.  */);
  5833   Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq);
  5834 
  5835   DEFVAR_LISP ("comp-eln-to-el-h", Vcomp_eln_to_el_h,
  5836     doc: /* Hash table eln-filename -> el-filename.  */);
  5837   Vcomp_eln_to_el_h = CALLN (Fmake_hash_table, QCtest, Qequal);
  5838 
  5839   DEFVAR_LISP ("native-comp-eln-load-path", Vnative_comp_eln_load_path,
  5840     doc: /* List of directories to look for natively-compiled *.eln files.
  5841 
  5842 The *.eln files are actually looked for in a version-specific
  5843 subdirectory of each directory in this list.  That subdirectory
  5844 is determined by the value of `comp-native-version-dir'.
  5845 If the name of a directory in this list is not absolute, it is
  5846 assumed to be relative to `invocation-directory'.
  5847 The last directory of this list is assumed to be the one holding
  5848 the system *.eln files, which are the files produced when building
  5849 Emacs.  */);
  5850 
  5851   /* Temporary value in use for bootstrap.  We can't do better as
  5852      `invocation-directory' is still unset, will be fixed up during
  5853      dump reload.  */
  5854   Vnative_comp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil);
  5855 
  5856   DEFVAR_LISP ("native-comp-enable-subr-trampolines",
  5857                Vnative_comp_enable_subr_trampolines,
  5858     doc: /* If non-nil, enable generation of trampolines for calling primitives.
  5859 Trampolines are needed so that Emacs respects redefinition or advice of
  5860 primitive functions when they are called from Lisp code natively-compiled
  5861 at `native-comp-speed' of 2.
  5862 
  5863 By default, the value is t, and when Emacs sees a redefined or advised
  5864 primitive called from natively-compiled Lisp, it generates a trampoline
  5865 for it on-the-fly.
  5866 
  5867 If the value is a file name (a string), it specifies the directory in
  5868 which to deposit the generated trampolines, overriding the directories
  5869 in `native-comp-eln-load-path'.
  5870 
  5871 When this variable is nil, generation of trampolines is disabled.
  5872 
  5873 Disabling the generation of trampolines, when a trampoline for a redefined
  5874 or advised primitive is not already available from previous compilations,
  5875 means that such redefinition or advice will not have effect when calling
  5876 primitives from natively-compiled Lisp code.  That is, calls to primitives
  5877 without existing trampolines from natively-compiled Lisp will behave as if
  5878 the primitive was called directly from C, and will ignore its redefinition
  5879 and advice.  */);
  5880 
  5881   DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h,
  5882     doc: /* Hash table subr-name -> installed trampoline.
  5883 This is used to prevent double trampoline instantiation, and also to
  5884 protect the trampolines against GC.  */);
  5885   Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table);
  5886 
  5887   DEFVAR_LISP ("comp-no-native-file-h", V_comp_no_native_file_h,
  5888     doc: /* Files for which no deferred compilation should be performed.
  5889 These files' compilation should not be deferred because the bytecode
  5890 version was explicitly requested by the user during load.
  5891 For internal use.  */);
  5892   V_comp_no_native_file_h = CALLN (Fmake_hash_table, QCtest, Qequal);
  5893 
  5894   DEFVAR_BOOL ("comp-file-preloaded-p", comp_file_preloaded_p,
  5895     doc: /* When non-nil, assume the file being compiled to be preloaded.  */);
  5896 
  5897   DEFVAR_LISP ("comp-loaded-comp-units-h", Vcomp_loaded_comp_units_h,
  5898     doc: /* Hash table recording all loaded compilation units, file -> CU.  */);
  5899   Vcomp_loaded_comp_units_h =
  5900     CALLN (Fmake_hash_table, QCweakness, Qvalue, QCtest, Qequal);
  5901 
  5902   DEFVAR_LISP ("comp-subr-arities-h", Vcomp_subr_arities_h,
  5903     doc: /* Hash table recording the arity of Lisp primitives.
  5904 This is in case they are redefined so the compiler still knows how to
  5905 compile calls to them.
  5906 subr-name -> arity
  5907 For internal use.  */);
  5908   Vcomp_subr_arities_h = CALLN (Fmake_hash_table, QCtest, Qequal);
  5909 
  5910   Fprovide (intern_c_string ("native-compile"), Qnil);
  5911 #endif /* #ifdef HAVE_NATIVE_COMP */
  5912 
  5913   defsubr (&Snative_comp_available_p);
  5914 }

/* [<][>][^][v][top][bottom][index][help] */