From 5543338b0c6245f0d1939d9c2617b65ded59ca3b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Feb 2020 15:53:42 +0000 Subject: [PATCH] Optimize relocation classes for object duplication Merge duplicated objects during final. Precendece is: 1 d-default 2 d-impure 3 d-ephemeral Now every object identify uniquely a relocation class. Because of this there's no need to keep the reloc class into m-var. --- lisp/emacs-lisp/comp.el | 95 +++++++++++++++++-------------- src/comp.c | 121 +++++++++++++++++++++++----------------- 2 files changed, 124 insertions(+), 92 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6ad97062b42..7792605fff8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -318,10 +318,7 @@ structure.") 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) @@ -344,31 +341,15 @@ structure.") "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. @@ -642,7 +623,7 @@ STACK-OFF is the index of the first slot frame involved." (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. @@ -679,11 +660,12 @@ If DST-N is specified use it otherwise assume it to be the current slot." "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. @@ -1281,13 +1263,11 @@ Top-level forms for the current context are rendered too." ;; 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)) @@ -1674,10 +1654,11 @@ Here goes everything that can be done not iteratively (read once). ;; 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." @@ -1967,15 +1948,47 @@ These are substituted with a normal 'set' op." ;;; 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))) diff --git a/src/comp.c b/src/comp.c index 0fc6e412924..bcb0c69986d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -185,6 +185,9 @@ typedef struct { 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; @@ -197,6 +200,11 @@ typedef struct { const char data[]; } static_obj_t; +typedef struct { + gcc_jit_rvalue *array; + gcc_jit_rvalue *idx; +} imm_reloc_t; + /* Helper functions called by the run-time. @@ -387,18 +395,43 @@ register_emitter (Lisp_Object key, void *func) 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 @@ -912,7 +945,7 @@ emit_make_fixnum (gcc_jit_rvalue *obj) } 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)))); @@ -922,28 +955,20 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class) 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 * @@ -1046,7 +1071,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) 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 ( @@ -1157,8 +1182,7 @@ emit_mvar_val (Lisp_Object mvar) 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)); @@ -1193,7 +1217,7 @@ emit_set_internal (Lisp_Object args) 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); @@ -1571,20 +1595,15 @@ emit_limple_insn (Lisp_Object insn) 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)) { @@ -1807,7 +1826,7 @@ declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, 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 = @@ -1830,12 +1849,6 @@ declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, 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), @@ -2449,11 +2462,11 @@ define_CAR_CDR (void) 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, @@ -2462,7 +2475,7 @@ define_CAR_CDR (void) 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]; @@ -2842,12 +2855,12 @@ define_bool_to_lisp_obj (void) 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. */ @@ -3206,8 +3219,14 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, 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; @@ -3231,8 +3250,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, 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 -- 2.39.5