(require 'gv)
(require 'cl-lib)
(require 'cl-extra)
+(require 'cl-macs)
(require 'subr-x)
(defgroup comp nil
(defvar comp-pass nil
"Every pass has the right to bind what it likes here.")
-(defvar comp-emitting-impure nil "Non nil to emit only impure objects.")
+(defvar comp-curr-allocation-class 'd-base
+ "Current allocation class.
+Can be one of: 'd-base', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.")
(defconst comp-passes '(comp-spill-lap
comp-limplify
(d-base (make-comp-data-container) :type comp-data-container
:documentation "Standard data relocated in use by functions.")
(d-impure (make-comp-data-container) :type comp-data-container
- :documentation "Data relocated that cannot be moved into pure space.
-This is tipically for top-level forms other than defun."))
+ :documentation "Relocated data that cannot be moved into pure space.
+This is tipically for top-level forms other than defun.")
+ (d-ephemeral (make-comp-data-container) :type comp-data-container
+ :documentation "Relocated data not necessary after load."))
(cl-defstruct comp-args-base
(min nil :type number
(type nil :type symbol
:documentation "When non nil indicates the type when known at compile
time.")
- (impure nil :type boolean
- :documentation "When non nil can't be copied into pure space."))
+ (alloc-class nil :type symbol
+ :documentation "Can be one of: 'd-base' 'd-impure'
+ or 'd-ephemeral'."))
;; Special vars used by some passes
(defvar comp-func)
(push obj (comp-data-container-l cont))
(puthash obj (hash-table-count h) h))))
+(defsubst comp-alloc-class-to-container (alloc-class)
+ "Given ALLOC-CLASS return the data container for the current context.
+Assume allocaiton class 'd-base as default."
+ (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-base) comp-ctxt))
+
(defun comp-add-const-to-relocs (obj)
"Keep track of OBJ into the ctxt relocations.
The corresponding index is returned."
(comp-add-const-to-relocs-to-cont obj
- (if comp-emitting-impure
- (comp-ctxt-d-impure comp-ctxt)
- (comp-ctxt-d-base comp-ctxt))))
+ (comp-alloc-class-to-container
+ comp-curr-allocation-class)))
(defmacro comp-within-log-buff (&rest body)
"Execute BODY while at the end the log-buffer.
(when const-vld
(comp-add-const-to-relocs constant))
(make--comp-mvar :slot slot :const-vld const-vld :constant constant
- :type type :impure comp-emitting-impure))
+ :type type :alloc-class comp-curr-allocation-class))
(defun comp-new-frame (size &optional ssa)
"Return a clean frame of meta variables of size SIZE.
(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level))
(let ((form (byte-to-native-top-level-form form)))
(comp-emit (comp-call 'eval
- (let ((comp-emitting-impure t))
+ (let ((comp-curr-allocation-class 'd-impure))
(make-comp-mvar :constant form))
(make-comp-mvar :constant t)))))
;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no
;; reasons to be execute ever again. Therefore all objects can be
;; just impure.
- (let* ((comp-emitting-impure t)
+ (let* ((comp-curr-allocation-class 'd-impure)
(func (make-comp-func :name 'top-level-run
:c-name "top_level_run"
:args (make-comp-args :min 1 :max 1)
;; this form is called 'minimal SSA form'.
;; This pass should be run every time basic blocks or m-var are shuffled.
-(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type)
+(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type
+ (alloc-class comp-curr-allocation-class))
(let ((mvar (make--comp-mvar :slot slot
:const-vld const-vld
:constant constant
- :type type)))
+ :type type
+ :alloc-class alloc-class)))
(setf (comp-mvar-id mvar) (sxhash-eq mvar))
mvar))
Prepare every function for final compilation and drive the C back-end."
(comp-data-container-check (comp-ctxt-d-base comp-ctxt))
(comp-data-container-check (comp-ctxt-d-impure comp-ctxt))
+ (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt))
(unless comp-dry-run
(comp--compile-ctxt-to-file name)))
#define PURE_RELOC_SYM "pure_reloc"
#define DATA_RELOC_SYM "d_reloc"
#define DATA_RELOC_IMPURE_SYM "d_reloc_imp"
+#define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph"
#define FUNC_LINK_TABLE_SYM "freloc_link_table"
#define LINK_TABLE_HASH_SYM "freloc_hash"
#define COMP_UNIT_SYM "comp_unit"
#define TEXT_DATA_RELOC_SYM "text_data_reloc"
#define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp"
+#define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph"
#define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed))
#define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug))
gcc_jit_rvalue *data_relocs;
/* Same as before but can't go in pure space. */
gcc_jit_rvalue *data_relocs_impure;
+ /* Same as before but content does not survive load phase. */
+ gcc_jit_rvalue *data_relocs_ephemeral;
/* Synthesized struct holding func relocs. */
gcc_jit_lvalue *func_relocs;
} comp_t;
Fputhash (key, value, comp.emitter_dispatcher);
}
+static gcc_jit_rvalue *
+alloc_class_to_reloc (Lisp_Object alloc_class)
+{
+ if (alloc_class == Qd_base)
+ return comp.data_relocs;
+ else if (alloc_class == Qd_impure)
+ return comp.data_relocs_impure;
+ else if (alloc_class == Qd_ephemeral)
+ return comp.data_relocs_ephemeral;
+ xsignal (Qnative_ice,
+ build_string ("inconsistent allocation class"));
+ assume (false);
+}
+
static void
emit_comment (const char *str)
{
}
static gcc_jit_rvalue *
-emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure)
+emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class)
{
emit_comment (format_string ("const lisp obj: %s",
SSDATA (Fprin1_to_string (obj, Qnil))));
comp.void_ptr_type,
NULL));
- Lisp_Object container = impure ? CALL1I (comp-ctxt-d-impure, Vcomp_ctxt)
- : CALL1I (comp-ctxt-d-base, Vcomp_ctxt);
+ Lisp_Object container = CALL1I (comp-alloc-class-to-container, alloc_class);
Lisp_Object reloc_idx =
Fgethash (obj, CALL1I (comp-data-container-idx, container), Qnil);
eassert (!NILP (reloc_idx));
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_array_access (comp.ctxt,
NULL,
- impure ? comp.data_relocs_impure
- : comp.data_relocs,
+ alloc_class_to_reloc (alloc_class),
reloc_n));
}
emit_NILP (gcc_jit_rvalue *x)
{
emit_comment ("NILP");
- return emit_EQ (x, emit_const_lisp_obj (Qnil, Qnil));
+ return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_base));
}
static gcc_jit_rvalue *
gcc_jit_rvalue *args[] =
{ emit_CONSP (x),
- emit_const_lisp_obj (Qconsp, Qnil),
+ emit_const_lisp_obj (Qconsp, Qd_base),
x };
gcc_jit_block_add_eval (
return emit_cast (comp.lisp_obj_type, word);
}
/* Other const objects are fetched from the reloc array. */
- return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar));
+ return emit_const_lisp_obj (constant,
+ CALL1I (comp-mvar-alloc-class, mvar));
}
return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar));
gcc_jit_rvalue *gcc_args[4];
FOR_EACH_TAIL (args)
gcc_args[i++] = emit_mvar_val (XCAR (args));
- gcc_args[2] = emit_const_lisp_obj (Qnil, Qnil);
+ gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_base);
gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.int_type,
SET_INTERNAL_SET);
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_array_access (comp.ctxt,
NULL,
- comp.data_relocs,
+ alloc_class_to_reloc (
+ CALL1I (comp-mvar-alloc-class,
+ arg[0])),
reloc_n)));
}
else if (EQ (op, Qcomment))
declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt),
DATA_RELOC_IMPURE_SYM,
TEXT_DATA_RELOC_IMPURE_SYM);
+ comp.data_relocs_ephemeral =
+ declare_imported_data_relocs (CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt),
+ DATA_RELOC_EPHEMERAL_SYM,
+ TEXT_DATA_RELOC_EPHEMERAL_SYM);
}
/*
comp.block = is_nil_b;
gcc_jit_block_end_with_return (comp.block,
NULL,
- emit_const_lisp_obj (Qnil, Qnil));
+ emit_const_lisp_obj (Qnil, Qd_base));
comp.block = not_nil_b;
gcc_jit_rvalue *wrong_type_args[] =
- { emit_const_lisp_obj (Qlistp, Qnil), c };
+ { emit_const_lisp_obj (Qlistp, Qd_base), c };
gcc_jit_block_add_eval (comp.block,
NULL,
false));
gcc_jit_block_end_with_return (comp.block,
NULL,
- emit_const_lisp_obj (Qnil, Qnil));
+ emit_const_lisp_obj (Qnil, Qd_base));
}
comp.car = func[0];
comp.cdr = func[1];
comp.block = ret_t_block;
gcc_jit_block_end_with_return (ret_t_block,
NULL,
- emit_const_lisp_obj (Qt, Qnil));
+ emit_const_lisp_obj (Qt, Qd_base));
comp.block = ret_nil_block;
gcc_jit_block_end_with_return (ret_nil_block,
NULL,
- emit_const_lisp_obj (Qnil, Qnil));
-
+ emit_const_lisp_obj (Qnil, Qd_base));
}
/* Declare a function being compiled and add it to comp.exported_funcs_h. */
EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM);
Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM);
+ Lisp_Object *data_eph_relocs =
+ dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM);
void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
+ Lisp_Object volatile data_ephemeral_vec;
+
+ /* Note: data_ephemeral_vec is not GC protected except than by
+ this function frame. After this functions will be
+ deactivated GC will be free to collect it, but it MUST
+ survive till 'top_level_run' has finished his job. We store
+ into the ephemeral allocation class only objects that we know
+ are necessary exclusively during the first load. Once these
+ are collected we don't have to maintain them in the heap
+ forever. */
if (!(current_thread_reloc
&& pure_reloc
&& data_relocs
&& data_imp_relocs
+ && data_eph_relocs
&& freloc_link_table
&& top_level_run)
|| NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM),
comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM);
comp_u->data_impure_vec =
load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM);
+ data_ephemeral_vec =
+ load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM);
+
+ EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec));
+ for (EMACS_INT i = 0; i < d_vec_len; i++)
+ data_eph_relocs[i] = AREF (data_ephemeral_vec, i);
if (!NILP (Vpurify_flag))
/* Non impure can be copied into pure space. */
DEFSYM (Qnumberp, "numberp");
DEFSYM (Qintegerp, "integerp");
+ /* Allocation classes. */
+ DEFSYM (Qd_base, "d-base");
+ DEFSYM (Qd_impure, "d-impure");
+ DEFSYM (Qd_ephemeral, "d-ephemeral");
+
/* Others. */
DEFSYM (Qfixnum, "fixnum");
DEFSYM (Qscratch, "scratch");
projects / emacs.git / commitdiff