a value known at compile time.")
(type nil :type symbol
:documentation "When non nil indicates the type when known at compile
- time.")
- (alloc-class nil :type symbol
- :documentation "Can be one of: 'd-default' 'd-impure'
- or 'd-ephemeral'."))
+ time."))
;; Special vars used by some passes
(defvar comp-func)
"Type hint predicate for function name FUNC."
(when (memq func comp-type-hints) t))
-(defun comp-data-container-check (cont)
- "Sanity check CONT coherency."
- (cl-assert (= (length (comp-data-container-l cont))
- (hash-table-count (comp-data-container-idx cont)))))
-
-(defun comp-add-const-to-relocs-to-cont (obj cont)
- "Keep track of OBJ into the CONT relocation container.
-The corresponding index is returned."
- (let ((h (comp-data-container-idx cont)))
- (if-let ((idx (gethash obj h)))
- idx
- (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-default as default."
(cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) 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
- (comp-alloc-class-to-container
- comp-curr-allocation-class)))
+(defsubst comp-add-const-to-relocs (obj)
+ "Keep track of OBJ into the ctxt relocations."
+ (puthash obj t (comp-data-container-idx (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 :alloc-class comp-curr-allocation-class))
+ :type type))
(defun comp-new-frame (size &optional ssa)
"Return a clean frame of meta variables of size SIZE.
"Emit annotation STR."
(comp-emit `(comment ,str)))
-(defun comp-emit-setimm (val)
+(defsubst comp-emit-setimm (val)
"Set constant VAL to current slot."
- (let ((rel-idx (comp-add-const-to-relocs val)))
- (cl-assert (numberp rel-idx))
- (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val))))
+ (comp-add-const-to-relocs val)
+ ;; Leave relocation index nil on purpose, will be fixed-up in final
+ ;; by `comp-finalize-relocs'.
+ (comp-emit `(setimm ,(comp-slot) nil ,val)))
(defun comp-make-curr-block (block-name entry-sp &optional addr)
"Create a basic block with BLOCK-NAME and set it as current block.
;; 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
- (alloc-class comp-curr-allocation-class))
+(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type)
(let ((mvar (make--comp-mvar :slot slot
:const-vld const-vld
:constant constant
- :type type
- :alloc-class alloc-class)))
+ :type type)))
(setf (comp-mvar-id mvar) (sxhash-eq mvar))
mvar))
;; pruning in order to be sure that this is not dead-code. This
;; is now left to gcc, to be implemented only if we want a
;; reliable diagnostic here.
- (let ((values (apply f (mapcar #'comp-mvar-constant args))))
+ (let ((value (apply f (mapcar #'comp-mvar-constant args))))
;; See `comp-emit-setimm'.
+ (comp-add-const-to-relocs value)
(setf (car insn) 'setimm
- (cddr insn) (list (comp-add-const-to-relocs values) values))))))
+ (cddr insn) `(nil ,value))))))
(defun comp-propagate-insn (insn)
"Propagate within INSN."
\f
;;; Final pass specific code.
+(defun comp-finalize-container (cont)
+ "Finalize data container CONT."
+ (setf (comp-data-container-l cont)
+ (cl-loop with h = (comp-data-container-idx cont)
+ for obj each hash-keys of h
+ for i from 0
+ do (puthash obj i h)
+ collect obj)))
+
+(defun comp-finalize-relocs ()
+ "Finalize data containers for each relocation class.
+Remove immediate duplicates within relocation classes.
+Update all insn accordingly."
+ ;; Symbols imported by C inlined functions. We do this here because
+ ;; is better to add all objs to the relocation containers before we
+ ;; compacting them.
+ (mapc #'comp-add-const-to-relocs '(nil t consp listp))
+
+ (let* ((d-default (comp-ctxt-d-default comp-ctxt))
+ (d-default-idx (comp-data-container-idx d-default))
+ (d-impure (comp-ctxt-d-impure comp-ctxt))
+ (d-impure-idx (comp-data-container-idx d-impure))
+ (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt))
+ (d-ephemeral-idx (comp-data-container-idx d-ephemeral)))
+ ;; Remove things in d-impure that are already in d-default.
+ (cl-loop for obj being each hash-keys of d-impure-idx
+ when (gethash obj d-default-idx)
+ do (remhash obj d-impure-idx))
+ ;; Remove things in d-ephemeral that are already in d-default or
+ ;; d-impure.
+ (cl-loop for obj being each hash-keys of d-ephemeral-idx
+ when (or (gethash obj d-default-idx) (gethash obj d-impure-idx))
+ do (remhash obj d-ephemeral-idx))
+ ;; Fix-up indexes in each relocation class and fill corresponding
+ ;; reloc lists.
+ (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral))))
+
(defun comp-compile-ctxt-to-file (name)
"Compile as native code the current context naming it NAME.
Prepare every function for final compilation and drive the C back-end."
- (comp-data-container-check (comp-ctxt-d-default comp-ctxt))
- (comp-data-container-check (comp-ctxt-d-impure comp-ctxt))
- (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt))
- ;; TODO: here we could optimize cleaning up objects present in the
- ;; impure and or in the ephemeral container that are also in the
- ;; default one.
+ (comp-finalize-relocs)
(unless comp-dry-run
(comp--compile-ctxt-to-file name)))
gcc_jit_rvalue *data_relocs_ephemeral;
/* Synthesized struct holding func relocs. */
gcc_jit_lvalue *func_relocs;
+ Lisp_Object d_default_idx;
+ Lisp_Object d_impure_idx;
+ Lisp_Object d_ephemeral_idx;
} comp_t;
static comp_t comp;
const char data[];
} static_obj_t;
+typedef struct {
+ gcc_jit_rvalue *array;
+ gcc_jit_rvalue *idx;
+} imm_reloc_t;
+
\f
/*
Helper functions called by the run-time.
Fputhash (key, value, comp.emitter_dispatcher);
}
-static gcc_jit_rvalue *
-alloc_class_to_reloc (Lisp_Object alloc_class)
-{
- if (alloc_class == Qd_default)
- 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"));
+static imm_reloc_t
+obj_to_reloc (Lisp_Object obj)
+{
+ imm_reloc_t reloc;
+ Lisp_Object idx;
+
+ idx = Fgethash (obj, comp.d_default_idx, Qnil);
+ if (!NILP (idx)) {
+ reloc.array = comp.data_relocs;
+ goto found;
+ }
+
+ idx = Fgethash (obj, comp.d_impure_idx, Qnil);
+ if (!NILP (idx))
+ {
+ reloc.array = comp.data_relocs_impure;
+ goto found;
+ }
+
+ idx = Fgethash (obj, comp.d_ephemeral_idx, Qnil);
+ if (!NILP (idx))
+ {
+ reloc.array = comp.data_relocs_ephemeral;
+ goto found;
+ }
+
+ xsignal1 (Qnative_ice,
+ build_string ("cant't find data in relocation containers"));
assume (false);
+ found:
+ if (!FIXNUMP (idx))
+ xsignal1 (Qnative_ice,
+ build_string ("inconsistent data relocation container"));
+ reloc.idx = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.ptrdiff_type,
+ XFIXNUM (idx));
+ return reloc;
}
static void
}
static gcc_jit_rvalue *
-emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class)
+emit_const_lisp_obj (Lisp_Object obj)
{
emit_comment (format_string ("const lisp obj: %s",
SSDATA (Fprin1_to_string (obj, Qnil))));
gcc_jit_context_new_rvalue_from_ptr (comp.ctxt,
comp.void_ptr_type,
NULL));
-
- 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_rvalue *reloc_n =
- gcc_jit_context_new_rvalue_from_int (comp.ctxt,
- comp.ptrdiff_type,
- XFIXNUM (reloc_idx));
+ imm_reloc_t reloc = obj_to_reloc (obj);
return
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_array_access (comp.ctxt,
NULL,
- alloc_class_to_reloc (alloc_class),
- reloc_n));
+ reloc.array,
+ reloc.idx));
}
static gcc_jit_rvalue *
emit_NILP (gcc_jit_rvalue *x)
{
emit_comment ("NILP");
- return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_default));
+ return emit_EQ (x, emit_const_lisp_obj (Qnil));
}
static gcc_jit_rvalue *
gcc_jit_rvalue *args[] =
{ emit_CONSP (x),
- emit_const_lisp_obj (Qconsp, Qd_default),
+ emit_const_lisp_obj (Qconsp),
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-alloc-class, mvar));
+ return emit_const_lisp_obj (constant);
}
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, Qd_default);
+ gcc_args[2] = emit_const_lisp_obj (Qnil);
gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.int_type,
SET_INTERNAL_SET);
else if (EQ (op, Qsetimm))
{
/* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) 3 a). */
- gcc_jit_rvalue *reloc_n =
- gcc_jit_context_new_rvalue_from_int (comp.ctxt,
- comp.int_type,
- XFIXNUM (arg[1]));
emit_comment (SSDATA (Fprin1_to_string (arg[2], Qnil)));
+ imm_reloc_t reloc = obj_to_reloc (arg[2]);
emit_frame_assignment (
arg[0],
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_array_access (comp.ctxt,
NULL,
- alloc_class_to_reloc (
- CALL1I (comp-mvar-alloc-class,
- arg[0])),
- reloc_n)));
+ reloc.array,
+ reloc.idx)));
}
else if (EQ (op, Qcomment))
{
EMACS_INT d_reloc_len =
XFIXNUM (CALL1I (hash-table-count,
CALL1I (comp-data-container-idx, container)));
- Lisp_Object d_reloc = Fnreverse (CALL1I (comp-data-container-l, container));
+ Lisp_Object d_reloc = CALL1I (comp-data-container-l, container);
d_reloc = Fvconcat (1, &d_reloc);
gcc_jit_rvalue *reloc_struct =
static void
declare_imported_data (void)
{
- /* Imported symbols by inliner functions. */
- CALL1I (comp-add-const-to-relocs, Qnil);
- CALL1I (comp-add-const-to-relocs, Qt);
- CALL1I (comp-add-const-to-relocs, Qconsp);
- CALL1I (comp-add-const-to-relocs, Qlistp);
-
/* Imported objects. */
comp.data_relocs =
declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt),
comp.block = is_nil_b;
gcc_jit_block_end_with_return (comp.block,
NULL,
- emit_const_lisp_obj (Qnil, Qd_default));
+ emit_const_lisp_obj (Qnil));
comp.block = not_nil_b;
gcc_jit_rvalue *wrong_type_args[] =
- { emit_const_lisp_obj (Qlistp, Qd_default), c };
+ { emit_const_lisp_obj (Qlistp), c };
gcc_jit_block_add_eval (comp.block,
NULL,
false));
gcc_jit_block_end_with_return (comp.block,
NULL,
- emit_const_lisp_obj (Qnil, Qd_default));
+ emit_const_lisp_obj (Qnil));
}
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, Qd_default));
+ emit_const_lisp_obj (Qt));
comp.block = ret_nil_block;
gcc_jit_block_end_with_return (ret_nil_block,
NULL,
- emit_const_lisp_obj (Qnil, Qd_default));
+ emit_const_lisp_obj (Qnil));
}
/* Declare a function being compiled and add it to comp.exported_funcs_h. */
gcc_jit_context_set_int_option (comp.ctxt,
GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL,
SPEED);
- sigset_t oldset;
+ comp.d_default_idx =
+ CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt));
+ comp.d_impure_idx =
+ CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-impure, Vcomp_ctxt));
+ comp.d_ephemeral_idx =
+ CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt));
+ sigset_t oldset;
if (!noninteractive)
{
sigset_t blocked;
define_add1_sub1 ();
define_negate ();
- struct Lisp_Hash_Table *func_h
- = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt));
+ struct Lisp_Hash_Table *func_h =
+ XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt));
for (ptrdiff_t i = 0; i < func_h->count; i++)
declare_function (HASH_VALUE (func_h, i));
/* Compile all functions. Can't be done before because the
projects / emacs.git / commitdiff